1 {-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
2 -----------------------------------------------------------------------------
4 -- (c) The University of Glasgow 2004-2009.
6 -- Package management tool
8 -----------------------------------------------------------------------------
10 module Main (main) where
12 import Version ( version, targetOS, targetARCH )
13 import Distribution.InstalledPackageInfo.Binary()
14 import qualified Distribution.Simple.PackageIndex as PackageIndex
15 import Distribution.ModuleName hiding (main)
16 import Distribution.InstalledPackageInfo
17 import Distribution.Compat.ReadP
18 import Distribution.ParseUtils
19 import Distribution.Package hiding (depends)
20 import Distribution.Text
21 import Distribution.Version
22 import System.FilePath as FilePath
23 import qualified System.FilePath.Posix as FilePath.Posix
24 import System.Cmd ( rawSystem )
25 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
31 import System.Console.GetOpt
32 import qualified Control.Exception as Exception
35 import Data.Char ( isSpace, toLower )
37 import System.Directory ( doesDirectoryExist, getDirectoryContents,
38 doesFileExist, renameFile, removeFile,
40 import System.Exit ( exitWith, ExitCode(..) )
41 import System.Environment ( getArgs, getProgName, getEnv )
43 import System.IO.Error
45 import Control.Concurrent
47 import qualified Data.ByteString.Lazy as B
48 import qualified Data.Binary as Bin
49 import qualified Data.Binary.Get as Bin
51 #if defined(mingw32_HOST_OS)
52 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
57 #ifdef mingw32_HOST_OS
58 import GHC.ConsoleHandler
60 import System.Posix hiding (fdToHandle)
64 import System.Process(runInteractiveCommand)
65 import qualified System.Info(os)
68 #if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
69 import System.Console.Terminfo as Terminfo
72 -- -----------------------------------------------------------------------------
79 case getOpt Permute (flags ++ deprecFlags) args of
80 (cli,_,[]) | FlagHelp `elem` cli -> do
81 prog <- getProgramName
82 bye (usageInfo (usageHeader prog) flags)
83 (cli,_,[]) | FlagVersion `elem` cli ->
86 case getVerbosity Normal cli of
87 Right v -> runit v cli nonopts
90 prog <- getProgramName
91 die (concat errors ++ usageInfo (usageHeader prog) flags)
93 -- -----------------------------------------------------------------------------
94 -- Command-line syntax
101 | FlagConfig FilePath
102 | FlagGlobalConfig FilePath
111 | FlagVerbosity (Maybe String)
114 flags :: [OptDescr Flag]
116 Option [] ["user"] (NoArg FlagUser)
117 "use the current user's package database",
118 Option [] ["global"] (NoArg FlagGlobal)
119 "use the global package database",
120 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
121 "use the specified package config file",
122 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
123 "location of the global package config",
124 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
125 "never read the user package database",
126 Option [] ["force"] (NoArg FlagForce)
127 "ignore missing dependencies, directories, and libraries",
128 Option [] ["force-files"] (NoArg FlagForceFiles)
129 "ignore missing directories and libraries only",
130 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
131 "automatically build libs for GHCi (with register)",
132 Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
133 "expand environment variables (${name}-style) in input package descriptions",
134 Option ['?'] ["help"] (NoArg FlagHelp)
135 "display this help and exit",
136 Option ['V'] ["version"] (NoArg FlagVersion)
137 "output version information and exit",
138 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
139 "print output in easy-to-parse format for some commands",
140 Option [] ["names-only"] (NoArg FlagNamesOnly)
141 "only print package names, not versions; can only be used with list --simple-output",
142 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
143 "ignore case for substring matching",
144 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
145 "verbosity level (0-2, default 1)"
148 data Verbosity = Silent | Normal | Verbose
149 deriving (Show, Eq, Ord)
151 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
152 getVerbosity v [] = Right v
153 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
154 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
155 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
156 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
157 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
158 getVerbosity v (_ : fs) = getVerbosity v fs
160 deprecFlags :: [OptDescr Flag]
162 -- put deprecated flags here
165 ourCopyright :: String
166 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
168 usageHeader :: String -> String
169 usageHeader prog = substProg prog $
171 " $p init {path}\n" ++
172 " Create and initialise a package database at the location {path}.\n" ++
173 " Packages can be registered in the new database using the register\n" ++
174 " command with --package-conf={path}. To use the new database with GHC,\n" ++
175 " use GHC's -package-conf flag.\n" ++
177 " $p register {filename | -}\n" ++
178 " Register the package using the specified installed package\n" ++
179 " description. The syntax for the latter is given in the $p\n" ++
180 " documentation. The input file should be encoded in UTF-8.\n" ++
182 " $p update {filename | -}\n" ++
183 " Register the package, overwriting any other package with the\n" ++
184 " same name. The input file should be encoded in UTF-8.\n" ++
186 " $p unregister {pkg-id}\n" ++
187 " Unregister the specified package.\n" ++
189 " $p expose {pkg-id}\n" ++
190 " Expose the specified package.\n" ++
192 " $p hide {pkg-id}\n" ++
193 " Hide the specified package.\n" ++
195 " $p list [pkg]\n" ++
196 " List registered packages in the global database, and also the\n" ++
197 " user database if --user is given. If a package name is given\n" ++
198 " all the registered versions will be listed in ascending order.\n" ++
199 " Accepts the --simple-output flag.\n" ++
202 " Generate a graph of the package dependencies in a form suitable\n" ++
203 " for input for the graphviz tools. For example, to generate a PDF" ++
204 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
206 " $p find-module {module}\n" ++
207 " List registered packages exposing module {module} in the global\n" ++
208 " database, and also the user database if --user is given.\n" ++
209 " All the registered versions will be listed in ascending order.\n" ++
210 " Accepts the --simple-output flag.\n" ++
212 " $p latest {pkg-id}\n" ++
213 " Prints the highest registered version of a package.\n" ++
216 " Check the consistency of package depenencies and list broken packages.\n" ++
217 " Accepts the --simple-output flag.\n" ++
219 " $p describe {pkg}\n" ++
220 " Give the registered description for the specified package. The\n" ++
221 " description is returned in precisely the syntax required by $p\n" ++
224 " $p field {pkg} {field}\n" ++
225 " Extract the specified field of the package description for the\n" ++
226 " specified package. Accepts comma-separated multiple fields.\n" ++
229 " Dump the registered description for every package. This is like\n" ++
230 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
231 " by tools that parse the results, rather than humans. The output is\n" ++
232 " always encoded in UTF-8, regardless of the current locale.\n" ++
235 " Regenerate the package database cache. This command should only be\n" ++
236 " necessary if you added a package to the database by dropping a file\n" ++
237 " into the database directory manually. By default, the global DB\n" ++
238 " is recached; to recache a different DB use --user or --package-conf\n" ++
239 " as appropriate.\n" ++
241 " Substring matching is supported for {module} in find-module and\n" ++
242 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
243 " open substring ends (prefix*, *suffix, *infix*).\n" ++
245 " When asked to modify a database (register, unregister, update,\n"++
246 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
247 " default. Specifying --user causes it to act on the user database,\n"++
248 " or --package-conf can be used to act on another database\n"++
249 " entirely. When multiple of these options are given, the rightmost\n"++
250 " one is used as the database to act upon.\n"++
252 " Commands that query the package database (list, tree, latest, describe,\n"++
253 " field) operate on the list of databases specified by the flags\n"++
254 " --user, --global, and --package-conf. If none of these flags are\n"++
255 " given, the default is --global --user.\n"++
257 " The following optional flags are also accepted:\n"
259 substProg :: String -> String -> String
261 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
262 substProg prog (c:xs) = c : substProg prog xs
264 -- -----------------------------------------------------------------------------
267 data Force = NoForce | ForceFiles | ForceAll | CannotForce
270 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
272 runit :: Verbosity -> [Flag] -> [String] -> IO ()
273 runit verbosity cli nonopts = do
274 installSignalHandlers -- catch ^C and clean up
275 prog <- getProgramName
278 | FlagForce `elem` cli = ForceAll
279 | FlagForceFiles `elem` cli = ForceFiles
280 | otherwise = NoForce
281 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
282 expand_env_vars= FlagExpandEnvVars `elem` cli
283 splitFields fields = unfoldr splitComma (',':fields)
284 where splitComma "" = Nothing
285 splitComma fs = Just $ break (==',') (tail fs)
287 substringCheck :: String -> Maybe (String -> Bool)
288 substringCheck "" = Nothing
289 substringCheck "*" = Just (const True)
290 substringCheck [_] = Nothing
291 substringCheck (h:t) =
292 case (h, init t, last t) of
293 ('*',s,'*') -> Just (isInfixOf (f s) . f)
294 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
295 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
297 where f | FlagIgnoreCase `elem` cli = map toLower
300 glob x | System.Info.os=="mingw32" = do
301 -- glob echoes its argument, after win32 filename globbing
302 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
303 txt <- hGetContents o
305 glob x | otherwise = return [x]
308 -- first, parse the command
311 -- dummy command to demonstrate usage and permit testing
312 -- without messing things up; use glob to selectively enable
313 -- windows filename globbing for file parameters
314 -- register, update, FlagGlobalConfig, FlagConfig; others?
315 ["glob", filename] -> do
317 glob filename >>= print
319 ["init", filename] ->
320 initPackageDB filename verbosity cli
321 ["register", filename] ->
322 registerPackage filename verbosity cli
323 auto_ghci_libs expand_env_vars False force
324 ["update", filename] ->
325 registerPackage filename verbosity cli
326 auto_ghci_libs expand_env_vars True force
327 ["unregister", pkgid_str] -> do
328 pkgid <- readGlobPkgId pkgid_str
329 unregisterPackage pkgid verbosity cli force
330 ["expose", pkgid_str] -> do
331 pkgid <- readGlobPkgId pkgid_str
332 exposePackage pkgid verbosity cli force
333 ["hide", pkgid_str] -> do
334 pkgid <- readGlobPkgId pkgid_str
335 hidePackage pkgid verbosity cli force
337 listPackages verbosity cli Nothing Nothing
338 ["list", pkgid_str] ->
339 case substringCheck pkgid_str of
340 Nothing -> do pkgid <- readGlobPkgId pkgid_str
341 listPackages verbosity cli (Just (Id pkgid)) Nothing
342 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
344 showPackageDot verbosity cli
345 ["find-module", moduleName] -> do
346 let match = maybe (==moduleName) id (substringCheck moduleName)
347 listPackages verbosity cli Nothing (Just match)
348 ["latest", pkgid_str] -> do
349 pkgid <- readGlobPkgId pkgid_str
350 latestPackage verbosity cli pkgid
351 ["describe", pkgid_str] ->
352 case substringCheck pkgid_str of
353 Nothing -> do pkgid <- readGlobPkgId pkgid_str
354 describePackage verbosity cli (Id pkgid)
355 Just m -> describePackage verbosity cli (Substring pkgid_str m)
356 ["field", pkgid_str, fields] ->
357 case substringCheck pkgid_str of
358 Nothing -> do pkgid <- readGlobPkgId pkgid_str
359 describeField verbosity cli (Id pkgid)
361 Just m -> describeField verbosity cli (Substring pkgid_str m)
364 checkConsistency verbosity cli
367 dumpPackages verbosity cli
370 recache verbosity cli
373 die ("missing command\n" ++
374 usageInfo (usageHeader prog) flags)
376 die ("command-line syntax error\n" ++
377 usageInfo (usageHeader prog) flags)
379 parseCheck :: ReadP a a -> String -> String -> IO a
380 parseCheck parser str what =
381 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
383 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
385 readGlobPkgId :: String -> IO PackageIdentifier
386 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
388 parseGlobPackageId :: ReadP r PackageIdentifier
394 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
396 -- globVersion means "all versions"
397 globVersion :: Version
398 globVersion = Version{ versionBranch=[], versionTags=["*"] }
400 -- -----------------------------------------------------------------------------
403 -- Some commands operate on a single database:
404 -- register, unregister, expose, hide
405 -- however these commands also check the union of the available databases
406 -- in order to check consistency. For example, register will check that
407 -- dependencies exist before registering a package.
409 -- Some commands operate on multiple databases, with overlapping semantics:
410 -- list, describe, field
413 = PackageDB { location :: FilePath,
414 packages :: [InstalledPackageInfo] }
416 type PackageDBStack = [PackageDB]
417 -- A stack of package databases. Convention: head is the topmost
420 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
421 allPackagesInStack = concatMap packages
423 getPkgDatabases :: Verbosity
424 -> Bool -- we are modifying, not reading
425 -> Bool -- read caches, if available
426 -> Bool -- expand vars, like ${pkgroot} and $topdir
428 -> IO (PackageDBStack,
429 -- the real package DB stack: [global,user] ++
430 -- DBs specified on the command line with -f.
432 -- which one to modify, if any
434 -- the package DBs specified on the command
435 -- line, or [global,user] otherwise. This
436 -- is used as the list of package DBs for
437 -- commands that just read the DB, such as 'list'.
439 getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
440 -- first we determine the location of the global package config. On Windows,
441 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
442 -- location is passed to the binary using the --global-config flag by the
444 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
446 case [ f | FlagGlobalConfig f <- my_flags ] of
447 [] -> do mb_dir <- getLibDir
449 Nothing -> die err_msg
451 r <- lookForPackageDBIn dir
453 Nothing -> die ("Can't find package database in " ++ dir)
454 Just path -> return path
455 fs -> return (last fs)
457 -- The value of the $topdir variable used in some package descriptions
458 -- Note that the way we calculate this is slightly different to how it
459 -- is done in ghc itself. We rely on the convention that the global
460 -- package db lives in ghc's libdir.
461 top_dir <- absolutePath (takeDirectory global_conf)
463 let no_user_db = FlagNoUserDb `elem` my_flags
465 -- get the location of the user package database, and create it if necessary
466 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
467 e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
470 if no_user_db then return Nothing else
472 Left _ -> return Nothing
474 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
475 dir = appdir </> subdir
476 r <- lookForPackageDBIn dir
478 Nothing -> return (Just (dir </> "package.conf.d", False))
479 Just f -> return (Just (f, True))
481 -- If the user database doesn't exist, and this command isn't a
482 -- "modify" command, then we won't attempt to create or use it.
484 | Just (user_conf,user_exists) <- mb_user_conf,
485 modify || user_exists = [user_conf, global_conf]
486 | otherwise = [global_conf]
488 e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
491 Left _ -> sys_databases
493 | last cs == "" -> init cs ++ sys_databases
495 where cs = parseSearchPath path
497 -- The "global" database is always the one at the bottom of the stack.
498 -- This is the database we modify by default.
499 virt_global_conf = last env_stack
501 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
502 where is_db_flag FlagUser
503 | Just (user_conf, _user_exists) <- mb_user_conf
505 is_db_flag FlagGlobal = Just virt_global_conf
506 is_db_flag (FlagConfig f) = Just f
507 is_db_flag _ = Nothing
509 let flag_db_names | null db_flags = env_stack
510 | otherwise = reverse (nub db_flags)
512 -- For a "modify" command, treat all the databases as
513 -- a stack, where we are modifying the top one, but it
514 -- can refer to packages in databases further down the
517 -- -f flags on the command line add to the database
518 -- stack, unless any of them are present in the stack
520 let final_stack = filter (`notElem` env_stack)
521 [ f | FlagConfig f <- reverse my_flags ]
524 -- the database we actually modify is the one mentioned
525 -- rightmost on the command-line.
527 | not modify = Nothing
528 | null db_flags = Just virt_global_conf
529 | otherwise = Just (last db_flags)
532 [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
533 if expand_vars then mungePackageDBPaths top_dir db else return db
534 | db_path <- final_stack ]
536 let flag_db_stack = [ db | db_name <- flag_db_names,
537 db <- db_stack, location db == db_name ]
539 return (db_stack, to_modify, flag_db_stack)
542 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
543 lookForPackageDBIn dir = do
544 let path_dir = dir </> "package.conf.d"
545 exists_dir <- doesDirectoryExist path_dir
546 if exists_dir then return (Just path_dir) else do
547 let path_file = dir </> "package.conf"
548 exists_file <- doesFileExist path_file
549 if exists_file then return (Just path_file) else return Nothing
551 readParseDatabase :: Verbosity
552 -> Maybe (FilePath,Bool)
557 readParseDatabase verbosity mb_user_conf use_cache path
558 -- the user database (only) is allowed to be non-existent
559 | Just (user_conf,False) <- mb_user_conf, path == user_conf
560 = return PackageDB { location = path, packages = [] }
562 = do e <- tryIO $ getDirectoryContents path
565 pkgs <- parseMultiPackageConf verbosity path
566 return PackageDB{ location = path, packages = pkgs }
568 | not use_cache -> ignore_cache
570 let cache = path </> cachefilename
571 tdir <- getModificationTime path
572 e_tcache <- tryIO $ getModificationTime cache
575 when (verbosity > Normal) $
576 warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
579 | tcache >= tdir -> do
580 when (verbosity > Normal) $
581 putStrLn ("using cache: " ++ cache)
582 pkgs <- myReadBinPackageDB cache
583 let pkgs' = map convertPackageInfoIn pkgs
584 return PackageDB { location = path, packages = pkgs' }
586 when (verbosity >= Normal) $ do
587 warn ("WARNING: cache is out of date: " ++ cache)
588 warn " use 'ghc-pkg recache' to fix."
592 let confs = filter (".conf" `isSuffixOf`) fs
593 pkgs <- mapM (parseSingletonPackageConf verbosity) $
595 return PackageDB { location = path, packages = pkgs }
597 -- read the package.cache file strictly, to work around a problem with
598 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
599 -- after it has been completely read, leading to a sharing violation
601 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
602 myReadBinPackageDB filepath = do
603 h <- openBinaryFile filepath ReadMode
605 b <- B.hGet h (fromIntegral sz)
607 return $ Bin.runGet Bin.get b
609 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
610 parseMultiPackageConf verbosity file = do
611 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
612 str <- readUTF8File file
613 let pkgs = map convertPackageInfoIn $ read str
614 Exception.evaluate pkgs
616 die ("error while parsing " ++ file ++ ": " ++ show e)
618 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
619 parseSingletonPackageConf verbosity file = do
620 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
621 readUTF8File file >>= parsePackageInfo
623 cachefilename :: FilePath
624 cachefilename = "package.cache"
626 mungePackageDBPaths :: FilePath -> PackageDB -> IO PackageDB
627 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = do
628 -- It so happens that for both styles of package db ("package.conf"
629 -- files and "package.conf.d" dirs) the pkgroot is the parent directory
630 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
631 pkgroot <- absolutePath (takeDirectory (location db))
632 return db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
634 mungePackagePaths :: FilePath -> FilePath
635 -> InstalledPackageInfo -> InstalledPackageInfo
636 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
637 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
638 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
639 -- The "pkgroot" is the directory containing the package database.
641 -- Also perform a similar substitution for the older GHC-specific
642 -- "$topdir" variable. The "topdir" is the location of the ghc
643 -- installation (obtained from the -B option).
644 mungePackagePaths top_dir pkgroot pkg =
646 importDirs = munge_paths (importDirs pkg),
647 includeDirs = munge_paths (includeDirs pkg),
648 libraryDirs = munge_paths (libraryDirs pkg),
649 frameworkDirs = munge_paths (frameworkDirs pkg),
650 haddockInterfaces = munge_paths (haddockInterfaces pkg),
651 haddockHTMLs = munge_urls (haddockHTMLs pkg)
654 munge_paths = map munge_path
655 munge_urls = map munge_url
658 | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
659 | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
665 | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
666 | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
671 toUrlPath r p = "file:///"
672 -- URLs always use posix style '/' separators:
673 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
675 stripVarPrefix var (root:path')
676 | Just [sep] <- stripPrefix var root
677 , isPathSeparator sep
678 = Just (joinPath path')
680 stripVarPrefix _ _ = Nothing
683 -- -----------------------------------------------------------------------------
684 -- Creating a new package DB
686 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
687 initPackageDB filename verbosity _flags = do
688 let eexist = die ("cannot create: " ++ filename ++ " already exists")
689 b1 <- doesFileExist filename
691 b2 <- doesDirectoryExist filename
693 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
695 -- -----------------------------------------------------------------------------
698 registerPackage :: FilePath
701 -> Bool -- auto_ghci_libs
702 -> Bool -- expand_env_vars
706 registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
707 (db_stack, Just to_modify, _flag_dbs) <-
708 getPkgDatabases verbosity True True False{-expand vars-} my_flags
711 db_to_operate_on = my_head "register" $
712 filter ((== to_modify).location) db_stack
714 when (auto_ghci_libs && verbosity >= Silent) $
715 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
720 when (verbosity >= Normal) $
721 putStr "Reading package info from stdin ... "
722 -- fix the encoding to UTF-8, since this is an interchange format
723 hSetEncoding stdin utf8
726 when (verbosity >= Normal) $
727 putStr ("Reading package info from " ++ show f ++ " ... ")
730 expanded <- if expand_env_vars then expandEnvVars s force
733 pkg <- parsePackageInfo expanded
734 when (verbosity >= Normal) $
737 -- validate the expanded pkg, but register the unexpanded
738 pkgroot <- absolutePath (takeDirectory to_modify)
739 let top_dir = takeDirectory (location (last db_stack))
740 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
742 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
743 -- truncate the stack for validation, because we don't allow
744 -- packages lower in the stack to refer to those higher up.
745 validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
747 removes = [ RemovePackage p
748 | p <- packages db_to_operate_on,
749 sourcePackageId p == sourcePackageId pkg ]
751 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
755 -> IO InstalledPackageInfo
756 parsePackageInfo str =
757 case parseInstalledPackageInfo str of
758 ParseOk _warns ok -> return ok
759 ParseFailed err -> case locatedErrorMsg err of
760 (Nothing, s) -> die s
761 (Just l, s) -> die (show l ++ ": " ++ s)
763 -- -----------------------------------------------------------------------------
764 -- Making changes to a package database
766 data DBOp = RemovePackage InstalledPackageInfo
767 | AddPackage InstalledPackageInfo
768 | ModifyPackage InstalledPackageInfo
770 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
771 changeDB verbosity cmds db = do
772 let db' = updateInternalDB db cmds
773 isfile <- doesFileExist (location db)
775 then writeNewConfig verbosity (location db') (packages db')
777 createDirectoryIfMissing True (location db)
778 changeDBDir verbosity cmds db'
780 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
781 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
783 do_cmd pkgs (RemovePackage p) =
784 filter ((/= installedPackageId p) . installedPackageId) pkgs
785 do_cmd pkgs (AddPackage p) = p : pkgs
786 do_cmd pkgs (ModifyPackage p) =
787 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
790 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
791 changeDBDir verbosity cmds db = do
793 updateDBCache verbosity db
795 do_cmd (RemovePackage p) = do
796 let file = location db </> display (installedPackageId p) <.> "conf"
797 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
799 do_cmd (AddPackage p) = do
800 let file = location db </> display (installedPackageId p) <.> "conf"
801 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
802 writeFileUtf8Atomic file (showInstalledPackageInfo p)
803 do_cmd (ModifyPackage p) =
804 do_cmd (AddPackage p)
806 updateDBCache :: Verbosity -> PackageDB -> IO ()
807 updateDBCache verbosity db = do
808 let filename = location db </> cachefilename
809 when (verbosity > Normal) $
810 putStrLn ("writing cache " ++ filename)
811 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
813 if isPermissionError e
814 then die (filename ++ ": you don't have permission to modify this file")
817 -- -----------------------------------------------------------------------------
818 -- Exposing, Hiding, Unregistering are all similar
820 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
821 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
823 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
824 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
826 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
827 unregisterPackage = modifyPackage RemovePackage
830 :: (InstalledPackageInfo -> DBOp)
836 modifyPackage fn pkgid verbosity my_flags force = do
837 (db_stack, Just _to_modify, _flag_dbs) <-
838 getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
840 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
842 db_name = location db
845 pids = map sourcePackageId ps
847 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
848 new_db = updateInternalDB db cmds
850 old_broken = brokenPackages (allPackagesInStack db_stack)
851 rest_of_stack = filter ((/= db_name) . location) db_stack
852 new_stack = new_db : rest_of_stack
853 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
854 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
856 when (not (null newly_broken)) $
857 dieOrForceAll force ("unregistering " ++ display pkgid ++
858 " would break the following packages: "
859 ++ unwords (map display newly_broken))
861 changeDB verbosity cmds db
863 recache :: Verbosity -> [Flag] -> IO ()
864 recache verbosity my_flags = do
865 (db_stack, Just to_modify, _flag_dbs) <-
866 getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
868 db_to_operate_on = my_head "recache" $
869 filter ((== to_modify).location) db_stack
871 changeDB verbosity [] db_to_operate_on
873 -- -----------------------------------------------------------------------------
876 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
877 -> Maybe (String->Bool)
879 listPackages verbosity my_flags mPackageName mModuleName = do
880 let simple_output = FlagSimpleOutput `elem` my_flags
881 (db_stack, _, flag_db_stack) <-
882 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
884 let db_stack_filtered -- if a package is given, filter out all other packages
885 | Just this <- mPackageName =
886 [ db{ packages = filter (this `matchesPkg`) (packages db) }
887 | db <- flag_db_stack ]
888 | Just match <- mModuleName = -- packages which expose mModuleName
889 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
890 | db <- flag_db_stack ]
891 | otherwise = flag_db_stack
894 = [ db{ packages = sort_pkgs (packages db) }
895 | db <- db_stack_filtered ]
896 where sort_pkgs = sortBy cmpPkgIds
897 cmpPkgIds pkg1 pkg2 =
898 case pkgName p1 `compare` pkgName p2 of
901 EQ -> pkgVersion p1 `compare` pkgVersion p2
902 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
904 stack = reverse db_stack_sorted
906 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
908 pkg_map = allPackagesInStack db_stack
909 broken = map sourcePackageId (brokenPackages pkg_map)
911 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
912 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
914 pp_pkgs = map pp_pkg pkg_confs
916 | sourcePackageId p `elem` broken = printf "{%s}" doc
918 | otherwise = printf "(%s)" doc
919 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
922 InstalledPackageId ipid = installedPackageId p
923 pkg = display (sourcePackageId p)
925 show_simple = simplePackageList my_flags . allPackagesInStack
927 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
928 prog <- getProgramName
929 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
931 if simple_output then show_simple stack else do
933 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
934 mapM_ show_normal stack
937 show_colour withF db =
938 mconcat $ map (<#> termText "\n") $
939 (termText (location db) :
940 map (termText " " <#>) (map pp_pkg (packages db)))
943 | sourcePackageId p `elem` broken = withF Red doc
945 | otherwise = withF Blue doc
946 where doc | verbosity >= Verbose
947 = termText (printf "%s (%s)" pkg ipid)
951 InstalledPackageId ipid = installedPackageId p
952 pkg = display (sourcePackageId p)
954 is_tty <- hIsTerminalDevice stdout
956 then mapM_ show_normal stack
957 else do tty <- Terminfo.setupTermFromEnv
958 case Terminfo.getCapability tty withForegroundColor of
959 Nothing -> mapM_ show_normal stack
960 Just w -> runTermOutput tty $ mconcat $
961 map (show_colour w) stack
964 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
965 simplePackageList my_flags pkgs = do
966 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
968 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
969 when (not (null pkgs)) $
970 hPutStrLn stdout $ concat $ intersperse " " strs
972 showPackageDot :: Verbosity -> [Flag] -> IO ()
973 showPackageDot verbosity myflags = do
974 (_, _, flag_db_stack) <-
975 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
977 let all_pkgs = allPackagesInStack flag_db_stack
978 ipix = PackageIndex.fromList all_pkgs
981 let quote s = '"':s ++ "\""
982 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
984 let from = display (sourcePackageId p),
986 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
987 let to = display (sourcePackageId dep)
991 -- -----------------------------------------------------------------------------
992 -- Prints the highest (hidden or exposed) version of a package
994 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
995 latestPackage verbosity my_flags pkgid = do
996 (_, _, flag_db_stack) <-
997 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
999 ps <- findPackages flag_db_stack (Id pkgid)
1000 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
1002 show_pkg [] = die "no matches"
1003 show_pkg pids = hPutStrLn stdout (display (last pids))
1005 -- -----------------------------------------------------------------------------
1008 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
1009 describePackage verbosity my_flags pkgarg = do
1010 (_, _, flag_db_stack) <-
1011 getPkgDatabases verbosity False True{-use cache-} True{-expand vars-} my_flags
1012 ps <- findPackages flag_db_stack pkgarg
1015 dumpPackages :: Verbosity -> [Flag] -> IO ()
1016 dumpPackages verbosity my_flags = do
1017 (_, _, flag_db_stack) <-
1018 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1019 doDump (allPackagesInStack flag_db_stack)
1021 doDump :: [InstalledPackageInfo] -> IO ()
1023 -- fix the encoding to UTF-8, since this is an interchange format
1024 hSetEncoding stdout utf8
1025 mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
1027 -- PackageId is can have globVersion for the version
1028 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1029 findPackages db_stack pkgarg
1030 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1032 findPackagesByDB :: PackageDBStack -> PackageArg
1033 -> IO [(PackageDB, [InstalledPackageInfo])]
1034 findPackagesByDB db_stack pkgarg
1035 = case [ (db, matched)
1037 let matched = filter (pkgarg `matchesPkg`) (packages db),
1038 not (null matched) ] of
1039 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1042 pkg_msg (Id pkgid) = display pkgid
1043 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1045 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1047 = (pkgName pid == pkgName pid')
1048 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1050 realVersion :: PackageIdentifier -> Bool
1051 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1052 -- when versionBranch == [], this is a glob
1054 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1055 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1056 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1058 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
1059 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
1061 -- -----------------------------------------------------------------------------
1064 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
1065 describeField verbosity my_flags pkgarg fields = do
1066 (_, _, flag_db_stack) <-
1067 getPkgDatabases verbosity False True{-use cache-} True{-expand vars-} my_flags
1068 fns <- toFields fields
1069 ps <- findPackages flag_db_stack pkgarg
1070 mapM_ (selectFields fns) ps
1071 where toFields [] = return []
1072 toFields (f:fs) = case toField f of
1073 Nothing -> die ("unknown field: " ++ f)
1074 Just fn -> do fns <- toFields fs
1076 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1078 toField :: String -> Maybe (InstalledPackageInfo -> String)
1079 -- backwards compatibility:
1080 toField "import_dirs" = Just $ strList . importDirs
1081 toField "source_dirs" = Just $ strList . importDirs
1082 toField "library_dirs" = Just $ strList . libraryDirs
1083 toField "hs_libraries" = Just $ strList . hsLibraries
1084 toField "extra_libraries" = Just $ strList . extraLibraries
1085 toField "include_dirs" = Just $ strList . includeDirs
1086 toField "c_includes" = Just $ strList . includes
1087 toField "package_deps" = Just $ strList . map display. depends
1088 toField "extra_cc_opts" = Just $ strList . ccOptions
1089 toField "extra_ld_opts" = Just $ strList . ldOptions
1090 toField "framework_dirs" = Just $ strList . frameworkDirs
1091 toField "extra_frameworks"= Just $ strList . frameworks
1092 toField s = showInstalledPackageInfoField s
1094 strList :: [String] -> String
1098 -- -----------------------------------------------------------------------------
1099 -- Check: Check consistency of installed packages
1101 checkConsistency :: Verbosity -> [Flag] -> IO ()
1102 checkConsistency verbosity my_flags = do
1104 getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
1105 -- check behaves like modify for the purposes of deciding which
1106 -- databases to use, because ordering is important.
1108 let simple_output = FlagSimpleOutput `elem` my_flags
1110 let pkgs = allPackagesInStack db_stack
1113 (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1115 then do when (not simple_output) $ do
1116 _ <- reportValidateErrors [] ws "" Nothing
1120 when (not simple_output) $ do
1121 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1122 _ <- reportValidateErrors es ws " " Nothing
1126 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1128 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1129 where not_in p = sourcePackageId p `notElem` all_ps
1130 all_ps = map sourcePackageId pkgs1
1132 let not_broken_pkgs = filterOut broken_pkgs pkgs
1133 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1134 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1136 when (not (null all_broken_pkgs)) $ do
1138 then simplePackageList my_flags all_broken_pkgs
1140 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1141 "listed above, or because they depend on a broken package.")
1142 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1144 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1147 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1148 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1149 closure pkgs db_stack = go pkgs db_stack
1151 go avail not_avail =
1152 case partition (depsAvailable avail) not_avail of
1153 ([], not_avail') -> (avail, not_avail')
1154 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1156 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1158 depsAvailable pkgs_ok pkg = null dangling
1159 where dangling = filter (`notElem` pids) (depends pkg)
1160 pids = map installedPackageId pkgs_ok
1162 -- we want mutually recursive groups of package to show up
1163 -- as broken. (#1750)
1165 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1166 brokenPackages pkgs = snd (closure [] pkgs)
1168 -- -----------------------------------------------------------------------------
1169 -- Manipulating package.conf files
1171 type InstalledPackageInfoString = InstalledPackageInfo_ String
1173 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1174 convertPackageInfoOut
1175 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1176 hiddenModules = h })) =
1177 pkgconf{ exposedModules = map display e,
1178 hiddenModules = map display h }
1180 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1181 convertPackageInfoIn
1182 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1183 hiddenModules = h })) =
1184 pkgconf{ exposedModules = map convert e,
1185 hiddenModules = map convert h }
1186 where convert = fromJust . simpleParse
1188 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1189 writeNewConfig verbosity filename ipis = do
1190 when (verbosity >= Normal) $
1191 hPutStr stdout "Writing new package config file... "
1192 createDirectoryIfMissing True $ takeDirectory filename
1193 let shown = concat $ intersperse ",\n "
1194 $ map (show . convertPackageInfoOut) ipis
1195 fileContents = "[" ++ shown ++ "\n]"
1196 writeFileUtf8Atomic filename fileContents
1198 if isPermissionError e
1199 then die (filename ++ ": you don't have permission to modify this file")
1201 when (verbosity >= Normal) $
1202 hPutStrLn stdout "done."
1204 -----------------------------------------------------------------------------
1205 -- Sanity-check a new package config, and automatically build GHCi libs
1208 type ValidateError = (Force,String)
1209 type ValidateWarning = String
1211 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1213 instance Monad Validate where
1214 return a = V $ return (a, [], [])
1216 (a, es, ws) <- runValidate m
1217 (b, es', ws') <- runValidate (k a)
1218 return (b,es++es',ws++ws')
1220 verror :: Force -> String -> Validate ()
1221 verror f s = V (return ((),[(f,s)],[]))
1223 vwarn :: String -> Validate ()
1224 vwarn s = V (return ((),[],["Warning: " ++ s]))
1226 liftIO :: IO a -> Validate a
1227 liftIO k = V (k >>= \a -> return (a,[],[]))
1229 -- returns False if we should die
1230 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1231 -> String -> Maybe Force -> IO Bool
1232 reportValidateErrors es ws prefix mb_force = do
1233 mapM_ (warn . (prefix++)) ws
1234 oks <- mapM report es
1238 | Just force <- mb_force
1240 then do reportError (prefix ++ s ++ " (ignoring)")
1242 else if f < CannotForce
1243 then do reportError (prefix ++ s ++ " (use --force to override)")
1245 else do reportError err
1247 | otherwise = do reportError err
1252 validatePackageConfig :: InstalledPackageInfo
1254 -> Bool -- auto-ghc-libs
1255 -> Bool -- update, or check
1258 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1259 (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1260 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1261 when (not ok) $ exitWith (ExitFailure 1)
1263 checkPackageConfig :: InstalledPackageInfo
1265 -> Bool -- auto-ghc-libs
1266 -> Bool -- update, or check
1268 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1269 checkInstalledPackageId pkg db_stack update
1271 checkDuplicates db_stack pkg update
1272 mapM_ (checkDep db_stack) (depends pkg)
1273 checkDuplicateDepends (depends pkg)
1274 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1275 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1276 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1277 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1278 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1280 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1281 -- ToDo: check these somehow?
1282 -- extra_libraries :: [String],
1283 -- c_includes :: [String],
1285 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1287 checkInstalledPackageId ipi db_stack update = do
1288 let ipid@(InstalledPackageId str) = installedPackageId ipi
1289 when (null str) $ verror CannotForce "missing id field"
1290 let dups = [ p | p <- allPackagesInStack db_stack,
1291 installedPackageId p == ipid ]
1292 when (not update && not (null dups)) $
1293 verror CannotForce $
1294 "package(s) with this id already exist: " ++
1295 unwords (map (display.packageId) dups)
1297 -- When the package name and version are put together, sometimes we can
1298 -- end up with a package id that cannot be parsed. This will lead to
1299 -- difficulties when the user wants to refer to the package later, so
1300 -- we check that the package id can be parsed properly here.
1301 checkPackageId :: InstalledPackageInfo -> Validate ()
1302 checkPackageId ipi =
1303 let str = display (sourcePackageId ipi) in
1304 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1306 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1307 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1309 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1310 checkDuplicates db_stack pkg update = do
1312 pkgid = sourcePackageId pkg
1313 pkgs = packages (head db_stack)
1315 -- Check whether this package id already exists in this DB
1317 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1318 verror CannotForce $
1319 "package " ++ display pkgid ++ " is already installed"
1322 uncasep = map toLower . display
1323 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1325 when (not update && not (null dups)) $ verror ForceAll $
1326 "Package names may be treated case-insensitively in the future.\n"++
1327 "Package " ++ display pkgid ++
1328 " overlaps with: " ++ unwords (map display dups)
1330 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1331 checkDir = checkPath False True
1332 checkFile = checkPath False False
1333 checkDirURL = checkPath True True
1335 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1336 checkPath url_ok is_dir warn_only thisfield d
1337 | url_ok && ("http://" `isPrefixOf` d
1338 || "https://" `isPrefixOf` d) = return ()
1341 , Just d' <- stripPrefix "file://" d
1342 = checkPath False is_dir warn_only thisfield d'
1344 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1345 -- variables having been expanded already, see mungePackagePaths.
1347 | isRelative d = verror ForceFiles $
1348 thisfield ++ ": " ++ d ++ " is a relative path which "
1349 ++ "makes no sense (as there is nothing for it to be "
1350 ++ "relative to). You can make paths relative to the "
1351 ++ "package database itself by using ${pkgroot}."
1352 -- relative paths don't make any sense; #4134
1354 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1356 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1357 ++ if is_dir then "directory" else "file"
1361 else verror ForceFiles msg
1363 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1364 checkDep db_stack pkgid
1365 | pkgid `elem` pkgids = return ()
1366 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1367 ++ "\" doesn't exist")
1369 all_pkgs = allPackagesInStack db_stack
1370 pkgids = map installedPackageId all_pkgs
1372 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1373 checkDuplicateDepends deps
1374 | null dups = return ()
1375 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1376 unwords (map display dups))
1378 dups = [ p | (p:_:_) <- group (sort deps) ]
1380 checkHSLib :: [String] -> Bool -> String -> Validate ()
1381 checkHSLib dirs auto_ghci_libs lib = do
1382 let batch_lib_file = "lib" ++ lib ++ ".a"
1383 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1385 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1387 Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
1389 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1390 doesFileExistOnPath file path = go path
1391 where go [] = return Nothing
1392 go (p:ps) = do b <- doesFileExistIn file p
1393 if b then return (Just p) else go ps
1395 doesFileExistIn :: String -> String -> IO Bool
1396 doesFileExistIn lib d = doesFileExist (d </> lib)
1398 checkModules :: InstalledPackageInfo -> Validate ()
1399 checkModules pkg = do
1400 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1402 findModule modl = do
1403 -- there's no .hi file for GHC.Prim
1404 if modl == fromString "GHC.Prim" then return () else do
1405 let file = toFilePath modl <.> "hi"
1406 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1407 when (isNothing m) $
1408 verror ForceFiles ("file " ++ file ++ " is missing")
1410 checkGHCiLib :: String -> String -> String -> Bool -> IO ()
1411 checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
1412 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1413 | otherwise = return ()
1415 ghci_lib_file = lib <.> "o"
1417 -- automatically build the GHCi version of a batch lib,
1418 -- using ld --whole-archive.
1420 autoBuildGHCiLib :: String -> String -> String -> IO ()
1421 autoBuildGHCiLib dir batch_file ghci_file = do
1422 let ghci_lib_file = dir ++ '/':ghci_file
1423 batch_lib_file = dir ++ '/':batch_file
1424 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1425 #if defined(darwin_HOST_OS)
1426 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1427 #elif defined(mingw32_HOST_OS)
1428 execDir <- getLibDir
1429 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1431 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1433 when (r /= ExitSuccess) $ exitWith r
1434 hPutStrLn stderr (" done.")
1436 -- -----------------------------------------------------------------------------
1437 -- Searching for modules
1441 findModules :: [FilePath] -> IO [String]
1443 mms <- mapM searchDir paths
1446 searchDir path prefix = do
1447 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1448 searchEntries path prefix fs
1450 searchEntries path prefix [] = return []
1451 searchEntries path prefix (f:fs)
1452 | looks_like_a_module = do
1453 ms <- searchEntries path prefix fs
1454 return (prefix `joinModule` f : ms)
1455 | looks_like_a_component = do
1456 ms <- searchDir (path </> f) (prefix `joinModule` f)
1457 ms' <- searchEntries path prefix fs
1460 searchEntries path prefix fs
1463 (base,suffix) = splitFileExt f
1464 looks_like_a_module =
1465 suffix `elem` haskell_suffixes &&
1466 all okInModuleName base
1467 looks_like_a_component =
1468 null suffix && all okInModuleName base
1474 -- ---------------------------------------------------------------------------
1475 -- expanding environment variables in the package configuration
1477 expandEnvVars :: String -> Force -> IO String
1478 expandEnvVars str0 force = go str0 ""
1480 go "" acc = return $! reverse acc
1481 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1482 = do value <- lookupEnvVar var
1483 go rest (reverse value ++ acc)
1484 where close c = c == '}' || c == '\n' -- don't span newlines
1488 lookupEnvVar :: String -> IO String
1489 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1490 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1492 catchIO (System.Environment.getEnv nm)
1493 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1497 -----------------------------------------------------------------------------
1499 getProgramName :: IO String
1500 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1501 where str `withoutSuffix` suff
1502 | suff `isSuffixOf` str = take (length str - length suff) str
1505 bye :: String -> IO a
1506 bye s = putStr s >> exitWith ExitSuccess
1508 die :: String -> IO a
1511 dieWith :: Int -> String -> IO a
1514 prog <- getProgramName
1515 hPutStrLn stderr (prog ++ ": " ++ s)
1516 exitWith (ExitFailure ec)
1518 dieOrForceAll :: Force -> String -> IO ()
1519 dieOrForceAll ForceAll s = ignoreError s
1520 dieOrForceAll _other s = dieForcible s
1522 warn :: String -> IO ()
1525 ignoreError :: String -> IO ()
1526 ignoreError s = reportError (s ++ " (ignoring)")
1528 reportError :: String -> IO ()
1529 reportError s = do hFlush stdout; hPutStrLn stderr s
1531 dieForcible :: String -> IO ()
1532 dieForcible s = die (s ++ " (use --force to override)")
1534 my_head :: String -> [a] -> a
1535 my_head s [] = error s
1536 my_head _ (x : _) = x
1538 -----------------------------------------
1539 -- Cut and pasted from ghc/compiler/main/SysTools
1541 #if defined(mingw32_HOST_OS)
1542 subst :: Char -> Char -> String -> String
1543 subst a b ls = map (\ x -> if x == a then b else x) ls
1545 unDosifyPath :: FilePath -> FilePath
1546 unDosifyPath xs = subst '\\' '/' xs
1548 getLibDir :: IO (Maybe String)
1549 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1551 -- (getExecDir cmd) returns the directory in which the current
1552 -- executable, which should be called 'cmd', is running
1553 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1554 -- you'll get "/a/b/c" back as the result
1555 getExecDir :: String -> IO (Maybe String)
1557 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1558 where initN n = reverse . drop n . reverse
1559 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1561 getExecPath :: IO (Maybe String)
1562 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1564 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1565 ret <- c_GetModuleFileName nullPtr buf size
1568 _ | ret < size -> fmap Just $ peekCWString buf
1569 | otherwise -> try_size (size * 2)
1571 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
1572 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1574 getLibDir :: IO (Maybe String)
1575 getLibDir = return Nothing
1578 -----------------------------------------
1579 -- Adapted from ghc/compiler/utils/Panic
1581 installSignalHandlers :: IO ()
1582 installSignalHandlers = do
1583 threadid <- myThreadId
1585 interrupt = Exception.throwTo threadid
1586 (Exception.ErrorCall "interrupted")
1588 #if !defined(mingw32_HOST_OS)
1589 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1590 _ <- installHandler sigINT (Catch interrupt) Nothing
1593 -- GHC 6.3+ has support for console events on Windows
1594 -- NOTE: running GHCi under a bash shell for some reason requires
1595 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1596 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1597 -- why --SDM 17/12/2004
1598 let sig_handler ControlC = interrupt
1599 sig_handler Break = interrupt
1600 sig_handler _ = return ()
1602 _ <- installHandler (Catch sig_handler)
1606 #if mingw32_HOST_OS || mingw32_TARGET_OS
1607 throwIOIO :: Exception.IOException -> IO a
1608 throwIOIO = Exception.throwIO
1611 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1612 catchIO = Exception.catch
1614 catchError :: IO a -> (String -> IO a) -> IO a
1615 catchError io handler = io `Exception.catch` handler'
1616 where handler' (Exception.ErrorCall err) = handler err
1618 tryIO :: IO a -> IO (Either Exception.IOException a)
1619 tryIO = Exception.try
1621 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1622 writeBinaryFileAtomic targetFile obj =
1623 withFileAtomic targetFile $ \h -> do
1624 hSetBinaryMode h True
1625 B.hPutStr h (Bin.encode obj)
1627 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1628 writeFileUtf8Atomic targetFile content =
1629 withFileAtomic targetFile $ \h -> do
1633 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1634 -- to use text files here, rather than binary files.
1635 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1636 withFileAtomic targetFile write_content = do
1637 (newFile, newHandle) <- openNewFile targetDir template
1638 do write_content newHandle
1640 #if mingw32_HOST_OS || mingw32_TARGET_OS
1641 renameFile newFile targetFile
1642 -- If the targetFile exists then renameFile will fail
1643 `catchIO` \err -> do
1644 exists <- doesFileExist targetFile
1646 then do removeFileSafe targetFile
1647 -- Big fat hairy race condition
1648 renameFile newFile targetFile
1649 -- If the removeFile succeeds and the renameFile fails
1650 -- then we've lost the atomic property.
1653 renameFile newFile targetFile
1655 `Exception.onException` do hClose newHandle
1656 removeFileSafe newFile
1658 template = targetName <.> "tmp"
1659 targetDir | null targetDir_ = "."
1660 | otherwise = targetDir_
1661 --TODO: remove this when takeDirectory/splitFileName is fixed
1662 -- to always return a valid dir
1663 (targetDir_,targetName) = splitFileName targetFile
1665 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1666 openNewFile dir template = do
1667 -- this was added to System.IO in 6.12.1
1668 -- we must use this version because the version below opens the file
1670 openTempFileWithDefaultPermissions dir template
1672 -- | The function splits the given string to substrings
1673 -- using 'isSearchPathSeparator'.
1674 parseSearchPath :: String -> [FilePath]
1675 parseSearchPath path = split path
1677 split :: String -> [String]
1681 _:rest -> chunk : split rest
1685 #ifdef mingw32_HOST_OS
1686 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1690 (chunk', rest') = break isSearchPathSeparator s
1692 readUTF8File :: FilePath -> IO String
1693 readUTF8File file = do
1694 h <- openFile file ReadMode
1695 -- fix the encoding to UTF-8
1699 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1700 removeFileSafe :: FilePath -> IO ()
1702 removeFile fn `catchIO` \ e ->
1703 when (not $ isDoesNotExistError e) $ ioError e
1705 absolutePath :: FilePath -> IO FilePath
1706 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory