import Version ( version, targetOS, targetARCH )
import Distribution.InstalledPackageInfo
import Distribution.Compat.ReadP
+import Distribution.ParseUtils ( showError )
import Distribution.Package
-import Distribution.License
import Distribution.Version
import Compat.Directory ( getAppUserDataDirectory )
-import Control.Exception ( catch, throw, evaluate )
-
-import Prelude hiding ( catch )
+import Control.Exception ( evaluate )
+import qualified Control.Exception as Exception
-import Package -- the old package config type
+import Prelude
#if __GLASGOW_HASKELL__ < 603
#include "config.h"
import Data.Char ( isSpace )
import Monad
import Directory
-import System ( getEnv, getArgs, getProgName,
+import System ( getArgs, getProgName,
system, exitWith,
ExitCode(..)
)
-import IO hiding ( catch )
-import List ( isPrefixOf, isSuffixOf )
-
-import ParsePkgConfLite
+import System.IO
+import Data.List ( isPrefixOf, isSuffixOf, intersperse )
#include "../../includes/ghcconfig.h"
str <- readFile filename
let packages = read str
evaluate packages
- `catch` \_ -> die (filename ++ ": parse error in package config file\n")
+ `Exception.catch` \_ ->
+ die (filename ++ ": parse error in package config file")
return (filename,packages)
emptyPackageConfig :: String
putStr "Reading package info from stdin... "
getContents
f -> do
- putStr ("Reading package info from " ++ show f)
+ putStr ("Reading package info from " ++ show f ++ " ")
readFile f
pkg <- parsePackageInfo s defines force
putStrLn "done."
validatePackageConfig pkg db_stack auto_ghci_libs update force
- new_details <- updatePackageDB (snd db_to_operate_on) pkg
+ new_details <- updatePackageDB db_stack (snd db_to_operate_on) pkg
savePackageConfig db_filename
maybeRestoreOldConfig db_filename $
writeNewConfig db_filename new_details
parsePackageInfo str defines force =
case parseInstalledPackageInfo str of
Right ok -> return ok
- Left err -> do
- old_pkg <- evaluate (parseOnePackageConfig str)
- `catch` \_ -> parse_failed
- putStr "Expanding embedded variables... "
- new_old_pkg <- expandEnvVars old_pkg defines force
- return (convertOldPackage old_pkg)
- where
- parse_failed = die "parse error in package info\n"
-
-convertOldPackage :: PackageConfig -> InstalledPackageInfo
-convertOldPackage
- Package {
- name = name,
- auto = auto,
- import_dirs = import_dirs,
- source_dirs = source_dirs,
- library_dirs = library_dirs,
- hs_libraries = hs_libraries,
- extra_libraries = extra_libraries,
- include_dirs = include_dirs,
- c_includes = c_includes,
- package_deps = package_deps,
- extra_ghc_opts = extra_ghc_opts,
- extra_cc_opts = extra_cc_opts,
- extra_ld_opts = extra_ld_opts,
- framework_dirs = framework_dirs,
- extra_frameworks= extra_frameworks
- }
- = InstalledPackageInfo {
- package = pkgNameToId name,
- license = AllRightsReserved,
- copyright = "",
- maintainer = "",
- author = "",
- stability = "",
- homepage = "",
- pkgUrl = "",
- description = "",
- category = "",
- exposed = auto,
- exposedModules = [],
- hiddenModules = [],
- importDirs = import_dirs,
- libraryDirs = library_dirs,
- hsLibraries = hs_libraries,
- extraLibraries = extra_libraries,
- includeDirs = include_dirs,
- includes = c_includes,
- depends = map pkgNameToId package_deps,
- extraHugsOpts = [],
- extraCcOpts = extra_cc_opts,
- extraLdOpts = extra_ld_opts,
- frameworkDirs = framework_dirs,
- extraFrameworks = extra_frameworks,
- haddockInterfaces = [],
- haddockHTMLs = []
- }
-
-
--- Used for converting old versionless package names to new PackageIdentifiers.
--- "Version [] []" is special: it means "no version" or "any version"
+ Left err -> die (showError err)
+
+-- Used for converting versionless package names to new
+-- PackageIdentifiers. "Version [] []" is special: it means "no
+-- version" or "any version"
pkgNameToId :: String -> PackageIdentifier
pkgNameToId name = PackageIdentifier name (Version [] [])
unregisterPackage [] _ = error "unregisterPackage"
unregisterPackage ((db_name, pkgs) : _) pkgid = do
checkConfigAccess db_name
- when (pkgid `notElem` map package pkgs)
- (die (db_name ++ ": package '" ++ showPackageId pkgid
- ++ "' not found\n"))
+ p <- findPackage [(db_name,pkgs)] pkgid
+ let pid = package p
savePackageConfig db_name
maybeRestoreOldConfig db_name $
- writeNewConfig db_name (filter ((/= pkgid) . package) pkgs)
+ writeNewConfig db_name (filter ((/= pid) . package) pkgs)
-- -----------------------------------------------------------------------------
-- Exposing
findPackage :: PackageDBStack -> PackageIdentifier -> IO InstalledPackageInfo
findPackage db_stack pkgid
- = case [ p | p <- all_pkgs, pkgid == package p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
- (p:ps) -> return p
+ = case [ p | p <- all_pkgs, pkgid `matches` p ] of
+ [] -> die ("cannot find package " ++ showPackageId pkgid)
+ [p] -> return p
+ ps -> die ("package " ++ showPackageId pkgid ++
+ " matches multiple packages: " ++
+ concat (intersperse ", " (
+ map (showPackageId.package) ps)))
where
all_pkgs = concat (map snd db_stack)
+matches :: PackageIdentifier -> InstalledPackageInfo -> Bool
+pid `matches` p =
+ pid == package p ||
+ not (realVersion pid) && pkgName pid == pkgName (package p)
+
-- -----------------------------------------------------------------------------
-- Field
checkConfigAccess filename = do
access <- getPermissions filename
when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file\n"))
+ (die (filename ++ ": you don't have permission to modify this file"))
maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
maybeRestoreOldConfig filename io
"restore the old configuration... ")
renameFile (filename ++ ".old") filename
hPutStrLn stdout "done."
- throw e
+ ioError e
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
-- Check whether this package id already exists in this DB
--
when (not update && (package pkg `elem` map package pkgs)) $
- die ("package " ++ showPackageId pkgid ++ " is already installed\n")
+ die ("package " ++ showPackageId pkgid ++ " is already installed")
--
-- if we are exposing this new package, then check that
-- there are no other exposed packages with the same name.
| otherwise = do
there <- doesDirectoryExist d
when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory\n"))
+ (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
| real_version && pkgid `elem` pkgids = return ()
| not real_version && pkgName pkgid `elem` pkg_names = return ()
| otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
- ++ " doesn't exist\n")
+ ++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
-- and don't check that it actually exists.
- real_version = versionBranch (pkgVersion pkgid) /= []
+ real_version = realVersion pkgid
all_pkgs = concat (map snd db_stack)
pkgids = map package all_pkgs
pkg_names = map pkgName pkgids
+realVersion :: PackageIdentifier -> Bool
+realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
+
checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
checkHSLib dirs auto_ghci_libs force lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
let ghci_lib_file = dir ++ '/':ghci_file
batch_lib_file = dir ++ '/':batch_file
hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
-#ifdef darwin_TARGET_OS
- system("ld -r -x -o " ++ ghci_lib_file ++
- " -all_load " ++ batch_lib_file)
-#else
-#ifdef mingw32_HOST_OS
+#if defined(darwin_TARGET_OS)
+ r <- system("ld -r -x -o " ++ ghci_lib_file ++
+ " -all_load " ++ batch_lib_file)
+#elif defined(mingw32_HOST_OS)
execDir <- getExecDir "/bin/ghc-pkg.exe"
- system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++ ghci_lib_file ++
- " --whole-archive " ++ batch_lib_file)
+ r <- system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++
+ ghci_lib_file ++ " --whole-archive " ++ batch_lib_file)
#else
- system("ld -r -x -o " ++ ghci_lib_file ++
- " --whole-archive " ++ batch_lib_file)
-#endif
+ r <- system("ld -r -x -o " ++ ghci_lib_file ++
+ " --whole-archive " ++ batch_lib_file)
#endif
+ when (r /= ExitSuccess) $ exitWith r
hPutStrLn stderr (" done.")
-- -----------------------------------------------------------------------------
-- Updating the DB with the new package.
updatePackageDB
- :: [InstalledPackageInfo]
+ :: PackageDBStack
+ -> [InstalledPackageInfo]
-> InstalledPackageInfo
-> IO [InstalledPackageInfo]
-updatePackageDB pkgs new_pkg = do
+updatePackageDB db_stack pkgs new_pkg = do
let
+ -- we update dependencies without version numbers to
+ -- match the actual versions of the relevant packages instaled.
+ updateDeps p = p{depends = map resolveDep (depends p)}
+
+ resolveDep pkgid
+ | realVersion pkgid = pkgid
+ | otherwise = lookupDep (pkgName pkgid)
+
+ lookupDep name
+ = head [ pid | p <- concat (map snd db_stack),
+ let pid = package p,
+ pkgName pid == name ]
+
is_exposed = exposed new_pkg
pkgid = package new_pkg
name = pkgName pkgid
| is_exposed && pkgName (package p) == name = p{ exposed = False }
| otherwise = p
--
- return (pkgs'++[new_pkg])
+ return (pkgs'++[updateDeps new_pkg])
+
+-- -----------------------------------------------------------------------------
+-- Searching for modules
+
+#if not_yet
+
+findModules :: [FilePath] -> IO [String]
+findModules paths =
+ mms <- mapM searchDir paths
+ return (concat mms)
+
+searchDir path prefix = do
+ fs <- getDirectoryEntries path `catch` \_ -> return []
+ searchEntries path prefix fs
+
+searchEntries path prefix [] = return []
+searchEntries path prefix (f:fs)
+ | looks_like_a_module = do
+ ms <- searchEntries path prefix fs
+ return (prefix `joinModule` f : ms)
+ | looks_like_a_component = do
+ ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f)
+ ms' <- searchEntries path prefix fs
+ return (ms ++ ms')
+ | otherwise
+ searchEntries path prefix fs
+
+ where
+ (base,suffix) = splitFileExt f
+ looks_like_a_module =
+ suffix `elem` haskell_suffixes &&
+ all okInModuleName base
+ looks_like_a_component =
+ null suffix && all okInModuleName base
+
+okInModuleName c
+
+#endif
-- -----------------------------------------------------------------------------
-- The old command-line syntax, supported for backwards compatibility
-- ---------------------------------------------------------------------------
+#ifdef OLD_STUFF
+-- ToDo: reinstate
expandEnvVars :: PackageConfig -> [(String, String)]
-> Bool -> IO PackageConfig
expandEnvVars pkg defines force = do
wordsBy p s = case dropWhile p s of
"" -> []
s' -> w : wordsBy p s'' where (w,s'') = break p s'
+#endif
-----------------------------------------------------------------------------
die s = do
hFlush stdout
prog <- getProgramName
- hPutStr stderr (prog ++ ": " ++ s)
+ hPutStrLn stderr (prog ++ ": " ++ s)
exitWith (ExitFailure 1)
dieOrForce :: Bool -> String -> IO ()
dieOrForce force s
| force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ "\n")
+ | otherwise = die s
-----------------------------------------------------------------------------