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
23 import System.Cmd ( rawSystem )
24 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
30 import System.Console.GetOpt
31 import qualified Control.Exception as Exception
34 import Data.Char ( isSpace, toLower )
36 import System.Directory ( doesDirectoryExist, getDirectoryContents,
37 doesFileExist, renameFile, removeFile )
38 import System.Exit ( exitWith, ExitCode(..) )
39 import System.Environment ( getArgs, getProgName, getEnv )
41 import System.IO.Error
43 import Control.Concurrent
45 import qualified Data.ByteString.Lazy as B
46 import qualified Data.Binary as Bin
47 import qualified Data.Binary.Get as Bin
49 #if defined(mingw32_HOST_OS)
50 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
55 #ifdef mingw32_HOST_OS
56 import GHC.ConsoleHandler
58 import System.Posix hiding (fdToHandle)
62 import System.Process(runInteractiveCommand)
63 import qualified System.Info(os)
66 #if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
67 import System.Console.Terminfo as Terminfo
70 -- -----------------------------------------------------------------------------
77 case getOpt Permute (flags ++ deprecFlags) args of
78 (cli,_,[]) | FlagHelp `elem` cli -> do
79 prog <- getProgramName
80 bye (usageInfo (usageHeader prog) flags)
81 (cli,_,[]) | FlagVersion `elem` cli ->
84 case getVerbosity Normal cli of
85 Right v -> runit v cli nonopts
88 prog <- getProgramName
89 die (concat errors ++ usageInfo (usageHeader prog) flags)
91 -- -----------------------------------------------------------------------------
92 -- Command-line syntax
100 | FlagGlobalConfig FilePath
108 | FlagVerbosity (Maybe String)
111 flags :: [OptDescr Flag]
113 Option [] ["user"] (NoArg FlagUser)
114 "use the current user's package database",
115 Option [] ["global"] (NoArg FlagGlobal)
116 "use the global package database",
117 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
118 "use the specified package config file",
119 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
120 "location of the global package config",
121 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
122 "never read the user package database",
123 Option [] ["force"] (NoArg FlagForce)
124 "ignore missing dependencies, directories, and libraries",
125 Option [] ["force-files"] (NoArg FlagForceFiles)
126 "ignore missing directories and libraries only",
127 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
128 "automatically build libs for GHCi (with register)",
129 Option ['?'] ["help"] (NoArg FlagHelp)
130 "display this help and exit",
131 Option ['V'] ["version"] (NoArg FlagVersion)
132 "output version information and exit",
133 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
134 "print output in easy-to-parse format for some commands",
135 Option [] ["names-only"] (NoArg FlagNamesOnly)
136 "only print package names, not versions; can only be used with list --simple-output",
137 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
138 "ignore case for substring matching",
139 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
140 "verbosity level (0-2, default 1)"
143 data Verbosity = Silent | Normal | Verbose
144 deriving (Show, Eq, Ord)
146 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
147 getVerbosity v [] = Right v
148 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
149 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
150 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
151 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
152 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
153 getVerbosity v (_ : fs) = getVerbosity v fs
155 deprecFlags :: [OptDescr Flag]
157 -- put deprecated flags here
160 ourCopyright :: String
161 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
163 usageHeader :: String -> String
164 usageHeader prog = substProg prog $
166 " $p init {path}\n" ++
167 " Create and initialise a package database at the location {path}.\n" ++
168 " Packages can be registered in the new database using the register\n" ++
169 " command with --package-conf={path}. To use the new database with GHC,\n" ++
170 " use GHC's -package-conf flag.\n" ++
172 " $p register {filename | -}\n" ++
173 " Register the package using the specified installed package\n" ++
174 " description. The syntax for the latter is given in the $p\n" ++
175 " documentation. The input file should be encoded in UTF-8.\n" ++
177 " $p update {filename | -}\n" ++
178 " Register the package, overwriting any other package with the\n" ++
179 " same name. The input file should be encoded in UTF-8.\n" ++
181 " $p unregister {pkg-id}\n" ++
182 " Unregister the specified package.\n" ++
184 " $p expose {pkg-id}\n" ++
185 " Expose the specified package.\n" ++
187 " $p hide {pkg-id}\n" ++
188 " Hide the specified package.\n" ++
190 " $p list [pkg]\n" ++
191 " List registered packages in the global database, and also the\n" ++
192 " user database if --user is given. If a package name is given\n" ++
193 " all the registered versions will be listed in ascending order.\n" ++
194 " Accepts the --simple-output flag.\n" ++
197 " Generate a graph of the package dependencies in a form suitable\n" ++
198 " for input for the graphviz tools. For example, to generate a PDF" ++
199 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
201 " $p find-module {module}\n" ++
202 " List registered packages exposing module {module} in the global\n" ++
203 " database, and also the user database if --user is given.\n" ++
204 " All the registered versions will be listed in ascending order.\n" ++
205 " Accepts the --simple-output flag.\n" ++
207 " $p latest {pkg-id}\n" ++
208 " Prints the highest registered version of a package.\n" ++
211 " Check the consistency of package depenencies and list broken packages.\n" ++
212 " Accepts the --simple-output flag.\n" ++
214 " $p describe {pkg}\n" ++
215 " Give the registered description for the specified package. The\n" ++
216 " description is returned in precisely the syntax required by $p\n" ++
219 " $p field {pkg} {field}\n" ++
220 " Extract the specified field of the package description for the\n" ++
221 " specified package. Accepts comma-separated multiple fields.\n" ++
224 " Dump the registered description for every package. This is like\n" ++
225 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
226 " by tools that parse the results, rather than humans. The output is\n" ++
227 " always encoded in UTF-8, regardless of the current locale.\n" ++
230 " Regenerate the package database cache. This command should only be\n" ++
231 " necessary if you added a package to the database by dropping a file\n" ++
232 " into the database directory manually. By default, the global DB\n" ++
233 " is recached; to recache a different DB use --user or --package-conf\n" ++
234 " as appropriate.\n" ++
236 " Substring matching is supported for {module} in find-module and\n" ++
237 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
238 " open substring ends (prefix*, *suffix, *infix*).\n" ++
240 " When asked to modify a database (register, unregister, update,\n"++
241 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
242 " default. Specifying --user causes it to act on the user database,\n"++
243 " or --package-conf can be used to act on another database\n"++
244 " entirely. When multiple of these options are given, the rightmost\n"++
245 " one is used as the database to act upon.\n"++
247 " Commands that query the package database (list, tree, latest, describe,\n"++
248 " field) operate on the list of databases specified by the flags\n"++
249 " --user, --global, and --package-conf. If none of these flags are\n"++
250 " given, the default is --global --user.\n"++
252 " The following optional flags are also accepted:\n"
254 substProg :: String -> String -> String
256 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
257 substProg prog (c:xs) = c : substProg prog xs
259 -- -----------------------------------------------------------------------------
262 data Force = NoForce | ForceFiles | ForceAll | CannotForce
265 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
267 runit :: Verbosity -> [Flag] -> [String] -> IO ()
268 runit verbosity cli nonopts = do
269 installSignalHandlers -- catch ^C and clean up
270 prog <- getProgramName
273 | FlagForce `elem` cli = ForceAll
274 | FlagForceFiles `elem` cli = ForceFiles
275 | otherwise = NoForce
276 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
277 splitFields fields = unfoldr splitComma (',':fields)
278 where splitComma "" = Nothing
279 splitComma fs = Just $ break (==',') (tail fs)
281 substringCheck :: String -> Maybe (String -> Bool)
282 substringCheck "" = Nothing
283 substringCheck "*" = Just (const True)
284 substringCheck [_] = Nothing
285 substringCheck (h:t) =
286 case (h, init t, last t) of
287 ('*',s,'*') -> Just (isInfixOf (f s) . f)
288 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
289 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
291 where f | FlagIgnoreCase `elem` cli = map toLower
294 glob x | System.Info.os=="mingw32" = do
295 -- glob echoes its argument, after win32 filename globbing
296 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
297 txt <- hGetContents o
299 glob x | otherwise = return [x]
302 -- first, parse the command
305 -- dummy command to demonstrate usage and permit testing
306 -- without messing things up; use glob to selectively enable
307 -- windows filename globbing for file parameters
308 -- register, update, FlagGlobalConfig, FlagConfig; others?
309 ["glob", filename] -> do
311 glob filename >>= print
313 ["init", filename] ->
314 initPackageDB filename verbosity cli
315 ["register", filename] ->
316 registerPackage filename verbosity cli auto_ghci_libs False force
317 ["update", filename] ->
318 registerPackage filename verbosity cli auto_ghci_libs True force
319 ["unregister", pkgid_str] -> do
320 pkgid <- readGlobPkgId pkgid_str
321 unregisterPackage pkgid verbosity cli force
322 ["expose", pkgid_str] -> do
323 pkgid <- readGlobPkgId pkgid_str
324 exposePackage pkgid verbosity cli force
325 ["hide", pkgid_str] -> do
326 pkgid <- readGlobPkgId pkgid_str
327 hidePackage pkgid verbosity cli force
329 listPackages verbosity cli Nothing Nothing
330 ["list", pkgid_str] ->
331 case substringCheck pkgid_str of
332 Nothing -> do pkgid <- readGlobPkgId pkgid_str
333 listPackages verbosity cli (Just (Id pkgid)) Nothing
334 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
336 showPackageDot verbosity cli
337 ["find-module", moduleName] -> do
338 let match = maybe (==moduleName) id (substringCheck moduleName)
339 listPackages verbosity cli Nothing (Just match)
340 ["latest", pkgid_str] -> do
341 pkgid <- readGlobPkgId pkgid_str
342 latestPackage verbosity cli pkgid
343 ["describe", pkgid_str] ->
344 case substringCheck pkgid_str of
345 Nothing -> do pkgid <- readGlobPkgId pkgid_str
346 describePackage verbosity cli (Id pkgid)
347 Just m -> describePackage verbosity cli (Substring pkgid_str m)
348 ["field", pkgid_str, fields] ->
349 case substringCheck pkgid_str of
350 Nothing -> do pkgid <- readGlobPkgId pkgid_str
351 describeField verbosity cli (Id pkgid)
353 Just m -> describeField verbosity cli (Substring pkgid_str m)
356 checkConsistency verbosity cli
359 dumpPackages verbosity cli
362 recache verbosity cli
365 die ("missing command\n" ++
366 usageInfo (usageHeader prog) flags)
368 die ("command-line syntax error\n" ++
369 usageInfo (usageHeader prog) flags)
371 parseCheck :: ReadP a a -> String -> String -> IO a
372 parseCheck parser str what =
373 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
375 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
377 readGlobPkgId :: String -> IO PackageIdentifier
378 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
380 parseGlobPackageId :: ReadP r PackageIdentifier
386 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
388 -- globVersion means "all versions"
389 globVersion :: Version
390 globVersion = Version{ versionBranch=[], versionTags=["*"] }
392 -- -----------------------------------------------------------------------------
395 -- Some commands operate on a single database:
396 -- register, unregister, expose, hide
397 -- however these commands also check the union of the available databases
398 -- in order to check consistency. For example, register will check that
399 -- dependencies exist before registering a package.
401 -- Some commands operate on multiple databases, with overlapping semantics:
402 -- list, describe, field
405 = PackageDB { location :: FilePath,
406 packages :: [InstalledPackageInfo] }
408 type PackageDBStack = [PackageDB]
409 -- A stack of package databases. Convention: head is the topmost
412 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
413 allPackagesInStack = concatMap packages
415 getPkgDatabases :: Verbosity
416 -> Bool -- we are modifying, not reading
417 -> Bool -- read caches, if available
419 -> IO (PackageDBStack,
420 -- the real package DB stack: [global,user] ++
421 -- DBs specified on the command line with -f.
423 -- which one to modify, if any
425 -- the package DBs specified on the command
426 -- line, or [global,user] otherwise. This
427 -- is used as the list of package DBs for
428 -- commands that just read the DB, such as 'list'.
430 getPkgDatabases verbosity modify use_cache my_flags = do
431 -- first we determine the location of the global package config. On Windows,
432 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
433 -- location is passed to the binary using the --global-config flag by the
435 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
437 case [ f | FlagGlobalConfig f <- my_flags ] of
438 [] -> do mb_dir <- getLibDir
440 Nothing -> die err_msg
442 r <- lookForPackageDBIn dir
444 Nothing -> die ("Can't find package database in " ++ dir)
445 Just path -> return path
446 fs -> return (last fs)
448 let no_user_db = FlagNoUserDb `elem` my_flags
450 -- get the location of the user package database, and create it if necessary
451 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
452 e_appdir <- try $ getAppUserDataDirectory "ghc"
455 if no_user_db then return Nothing else
457 Left _ -> return Nothing
459 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
460 dir = appdir </> subdir
461 r <- lookForPackageDBIn dir
463 Nothing -> return (Just (dir </> "package.conf.d", False))
464 Just f -> return (Just (f, True))
466 -- If the user database doesn't exist, and this command isn't a
467 -- "modify" command, then we won't attempt to create or use it.
469 | Just (user_conf,user_exists) <- mb_user_conf,
470 modify || user_exists = [user_conf, global_conf]
471 | otherwise = [global_conf]
473 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
476 Left _ -> sys_databases
478 | last cs == "" -> init cs ++ sys_databases
480 where cs = parseSearchPath path
482 -- The "global" database is always the one at the bottom of the stack.
483 -- This is the database we modify by default.
484 virt_global_conf = last env_stack
486 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
487 where is_db_flag FlagUser
488 | Just (user_conf, _user_exists) <- mb_user_conf
490 is_db_flag FlagGlobal = Just virt_global_conf
491 is_db_flag (FlagConfig f) = Just f
492 is_db_flag _ = Nothing
494 let flag_db_names | null db_flags = env_stack
495 | otherwise = reverse (nub db_flags)
497 -- For a "modify" command, treat all the databases as
498 -- a stack, where we are modifying the top one, but it
499 -- can refer to packages in databases further down the
502 -- -f flags on the command line add to the database
503 -- stack, unless any of them are present in the stack
505 let final_stack = filter (`notElem` env_stack)
506 [ f | FlagConfig f <- reverse my_flags ]
509 -- the database we actually modify is the one mentioned
510 -- rightmost on the command-line.
512 | not modify = Nothing
513 | null db_flags = Just virt_global_conf
514 | otherwise = Just (last db_flags)
516 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
518 let flag_db_stack = [ db | db_name <- flag_db_names,
519 db <- db_stack, location db == db_name ]
521 return (db_stack, to_modify, flag_db_stack)
524 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
525 lookForPackageDBIn dir = do
526 let path_dir = dir </> "package.conf.d"
527 exists_dir <- doesDirectoryExist path_dir
528 if exists_dir then return (Just path_dir) else do
529 let path_file = dir </> "package.conf"
530 exists_file <- doesFileExist path_file
531 if exists_file then return (Just path_file) else return Nothing
533 readParseDatabase :: Verbosity
534 -> Maybe (FilePath,Bool)
539 readParseDatabase verbosity mb_user_conf use_cache path
540 -- the user database (only) is allowed to be non-existent
541 | Just (user_conf,False) <- mb_user_conf, path == user_conf
542 = return PackageDB { location = path, packages = [] }
544 = do e <- try $ getDirectoryContents path
547 pkgs <- parseMultiPackageConf verbosity path
548 return PackageDB{ location = path, packages = pkgs }
550 | not use_cache -> ignore_cache
552 let cache = path </> cachefilename
553 tdir <- getModificationTime path
554 e_tcache <- try $ getModificationTime cache
557 when (verbosity > Normal) $
558 warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
561 | tcache >= tdir -> do
562 when (verbosity > Normal) $
563 putStrLn ("using cache: " ++ cache)
564 pkgs <- myReadBinPackageDB cache
565 let pkgs' = map convertPackageInfoIn pkgs
566 return PackageDB { location = path, packages = pkgs' }
568 when (verbosity >= Normal) $ do
569 warn ("WARNING: cache is out of date: " ++ cache)
570 warn " use 'ghc-pkg recache' to fix."
574 let confs = filter (".conf" `isSuffixOf`) fs
575 pkgs <- mapM (parseSingletonPackageConf verbosity) $
577 return PackageDB { location = path, packages = pkgs }
579 -- read the package.cache file strictly, to work around a problem with
580 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
581 -- after it has been completely read, leading to a sharing violation
583 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
584 myReadBinPackageDB filepath = do
585 h <- openBinaryFile filepath ReadMode
587 b <- B.hGet h (fromIntegral sz)
589 return $ Bin.runGet Bin.get b
591 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
592 parseMultiPackageConf verbosity file = do
593 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
594 str <- readUTF8File file
595 let pkgs = map convertPackageInfoIn $ read str
596 Exception.evaluate pkgs
598 die ("error while parsing " ++ file ++ ": " ++ show e)
600 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
601 parseSingletonPackageConf verbosity file = do
602 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
603 readUTF8File file >>= parsePackageInfo
605 cachefilename :: FilePath
606 cachefilename = "package.cache"
608 -- -----------------------------------------------------------------------------
609 -- Creating a new package DB
611 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
612 initPackageDB filename verbosity _flags = do
613 let eexist = die ("cannot create: " ++ filename ++ " already exists")
614 b1 <- doesFileExist filename
616 b2 <- doesDirectoryExist filename
618 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
620 -- -----------------------------------------------------------------------------
623 registerPackage :: FilePath
626 -> Bool -- auto_ghci_libs
630 registerPackage input verbosity my_flags auto_ghci_libs update force = do
631 (db_stack, Just to_modify, _flag_dbs) <-
632 getPkgDatabases verbosity True True my_flags
635 db_to_operate_on = my_head "register" $
636 filter ((== to_modify).location) db_stack
641 when (verbosity >= Normal) $
642 putStr "Reading package info from stdin ... "
643 -- fix the encoding to UTF-8, since this is an interchange format
644 hSetEncoding stdin utf8
647 when (verbosity >= Normal) $
648 putStr ("Reading package info from " ++ show f ++ " ... ")
651 expanded <- expandEnvVars s force
653 pkg <- parsePackageInfo expanded
654 when (verbosity >= Normal) $
657 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
658 -- truncate the stack for validation, because we don't allow
659 -- packages lower in the stack to refer to those higher up.
660 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
662 removes = [ RemovePackage p
663 | p <- packages db_to_operate_on,
664 sourcePackageId p == sourcePackageId pkg ]
666 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
670 -> IO InstalledPackageInfo
671 parsePackageInfo str =
672 case parseInstalledPackageInfo str of
673 ParseOk _warns ok -> return ok
674 ParseFailed err -> case locatedErrorMsg err of
675 (Nothing, s) -> die s
676 (Just l, s) -> die (show l ++ ": " ++ s)
678 -- -----------------------------------------------------------------------------
679 -- Making changes to a package database
681 data DBOp = RemovePackage InstalledPackageInfo
682 | AddPackage InstalledPackageInfo
683 | ModifyPackage InstalledPackageInfo
685 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
686 changeDB verbosity cmds db = do
687 let db' = updateInternalDB db cmds
688 isfile <- doesFileExist (location db)
690 then writeNewConfig verbosity (location db') (packages db')
692 createDirectoryIfMissing True (location db)
693 changeDBDir verbosity cmds db'
695 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
696 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
698 do_cmd pkgs (RemovePackage p) =
699 filter ((/= installedPackageId p) . installedPackageId) pkgs
700 do_cmd pkgs (AddPackage p) = p : pkgs
701 do_cmd pkgs (ModifyPackage p) =
702 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
705 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
706 changeDBDir verbosity cmds db = do
708 updateDBCache verbosity db
710 do_cmd (RemovePackage p) = do
711 let file = location db </> display (installedPackageId p) <.> "conf"
712 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
714 do_cmd (AddPackage p) = do
715 let file = location db </> display (installedPackageId p) <.> "conf"
716 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
717 writeFileUtf8Atomic file (showInstalledPackageInfo p)
718 do_cmd (ModifyPackage p) =
719 do_cmd (AddPackage p)
721 updateDBCache :: Verbosity -> PackageDB -> IO ()
722 updateDBCache verbosity db = do
723 let filename = location db </> cachefilename
724 when (verbosity > Normal) $
725 putStrLn ("writing cache " ++ filename)
726 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
728 if isPermissionError e
729 then die (filename ++ ": you don't have permission to modify this file")
732 -- -----------------------------------------------------------------------------
733 -- Exposing, Hiding, Unregistering are all similar
735 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
736 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
738 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
739 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
741 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
742 unregisterPackage = modifyPackage RemovePackage
745 :: (InstalledPackageInfo -> DBOp)
751 modifyPackage fn pkgid verbosity my_flags force = do
752 (db_stack, Just _to_modify, _flag_dbs) <-
753 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
755 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
757 db_name = location db
760 pids = map sourcePackageId ps
762 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
763 new_db = updateInternalDB db cmds
765 old_broken = brokenPackages (allPackagesInStack db_stack)
766 rest_of_stack = filter ((/= db_name) . location) db_stack
767 new_stack = new_db : rest_of_stack
768 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
769 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
771 when (not (null newly_broken)) $
772 dieOrForceAll force ("unregistering " ++ display pkgid ++
773 " would break the following packages: "
774 ++ unwords (map display newly_broken))
776 changeDB verbosity cmds db
778 recache :: Verbosity -> [Flag] -> IO ()
779 recache verbosity my_flags = do
780 (db_stack, Just to_modify, _flag_dbs) <-
781 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
783 db_to_operate_on = my_head "recache" $
784 filter ((== to_modify).location) db_stack
786 changeDB verbosity [] db_to_operate_on
788 -- -----------------------------------------------------------------------------
791 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
792 -> Maybe (String->Bool)
794 listPackages verbosity my_flags mPackageName mModuleName = do
795 let simple_output = FlagSimpleOutput `elem` my_flags
796 (db_stack, _, flag_db_stack) <-
797 getPkgDatabases verbosity False True{-use cache-} my_flags
799 let db_stack_filtered -- if a package is given, filter out all other packages
800 | Just this <- mPackageName =
801 [ db{ packages = filter (this `matchesPkg`) (packages db) }
802 | db <- flag_db_stack ]
803 | Just match <- mModuleName = -- packages which expose mModuleName
804 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
805 | db <- flag_db_stack ]
806 | otherwise = flag_db_stack
809 = [ db{ packages = sort_pkgs (packages db) }
810 | db <- db_stack_filtered ]
811 where sort_pkgs = sortBy cmpPkgIds
812 cmpPkgIds pkg1 pkg2 =
813 case pkgName p1 `compare` pkgName p2 of
816 EQ -> pkgVersion p1 `compare` pkgVersion p2
817 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
819 stack = reverse db_stack_sorted
821 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
823 pkg_map = allPackagesInStack db_stack
824 broken = map sourcePackageId (brokenPackages pkg_map)
826 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
827 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
829 pp_pkgs = map pp_pkg pkg_confs
831 | sourcePackageId p `elem` broken = printf "{%s}" doc
833 | otherwise = printf "(%s)" doc
834 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
837 InstalledPackageId ipid = installedPackageId p
838 pkg = display (sourcePackageId p)
840 show_simple = simplePackageList my_flags . allPackagesInStack
842 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
843 prog <- getProgramName
844 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
846 if simple_output then show_simple stack else do
848 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
849 mapM_ show_normal stack
852 show_colour withF db =
853 mconcat $ map (<#> termText "\n") $
854 (termText (location db) :
855 map (termText " " <#>) (map pp_pkg (packages db)))
858 | sourcePackageId p `elem` broken = withF Red doc
860 | otherwise = withF Blue doc
861 where doc | verbosity >= Verbose
862 = termText (printf "%s (%s)" pkg ipid)
866 InstalledPackageId ipid = installedPackageId p
867 pkg = display (sourcePackageId p)
869 is_tty <- hIsTerminalDevice stdout
871 then mapM_ show_normal stack
872 else do tty <- Terminfo.setupTermFromEnv
873 case Terminfo.getCapability tty withForegroundColor of
874 Nothing -> mapM_ show_normal stack
875 Just w -> runTermOutput tty $ mconcat $
876 map (show_colour w) stack
879 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
880 simplePackageList my_flags pkgs = do
881 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
883 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
884 when (not (null pkgs)) $
885 hPutStrLn stdout $ concat $ intersperse " " strs
887 showPackageDot :: Verbosity -> [Flag] -> IO ()
888 showPackageDot verbosity myflags = do
889 (_, _, flag_db_stack) <-
890 getPkgDatabases verbosity False True{-use cache-} myflags
892 let all_pkgs = allPackagesInStack flag_db_stack
893 ipix = PackageIndex.fromList all_pkgs
896 let quote s = '"':s ++ "\""
897 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
899 let from = display (sourcePackageId p),
901 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
902 let to = display (sourcePackageId dep)
906 -- -----------------------------------------------------------------------------
907 -- Prints the highest (hidden or exposed) version of a package
909 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
910 latestPackage verbosity my_flags pkgid = do
911 (_, _, flag_db_stack) <-
912 getPkgDatabases verbosity False True{-use cache-} my_flags
914 ps <- findPackages flag_db_stack (Id pkgid)
915 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
917 show_pkg [] = die "no matches"
918 show_pkg pids = hPutStrLn stdout (display (last pids))
920 -- -----------------------------------------------------------------------------
923 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
924 describePackage verbosity my_flags pkgarg = do
925 (_, _, flag_db_stack) <-
926 getPkgDatabases verbosity False True{-use cache-} my_flags
927 ps <- findPackages flag_db_stack pkgarg
930 dumpPackages :: Verbosity -> [Flag] -> IO ()
931 dumpPackages verbosity my_flags = do
932 (_, _, flag_db_stack) <-
933 getPkgDatabases verbosity False True{-use cache-} my_flags
934 doDump (allPackagesInStack flag_db_stack)
936 doDump :: [InstalledPackageInfo] -> IO ()
938 -- fix the encoding to UTF-8, since this is an interchange format
939 hSetEncoding stdout utf8
940 mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
942 -- PackageId is can have globVersion for the version
943 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
944 findPackages db_stack pkgarg
945 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
947 findPackagesByDB :: PackageDBStack -> PackageArg
948 -> IO [(PackageDB, [InstalledPackageInfo])]
949 findPackagesByDB db_stack pkgarg
950 = case [ (db, matched)
952 let matched = filter (pkgarg `matchesPkg`) (packages db),
953 not (null matched) ] of
954 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
957 pkg_msg (Id pkgid) = display pkgid
958 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
960 matches :: PackageIdentifier -> PackageIdentifier -> Bool
962 = (pkgName pid == pkgName pid')
963 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
965 realVersion :: PackageIdentifier -> Bool
966 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
967 -- when versionBranch == [], this is a glob
969 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
970 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
971 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
973 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
974 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
976 -- -----------------------------------------------------------------------------
979 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
980 describeField verbosity my_flags pkgarg fields = do
981 (_, _, flag_db_stack) <-
982 getPkgDatabases verbosity False True{-use cache-} my_flags
983 fns <- toFields fields
984 ps <- findPackages flag_db_stack pkgarg
985 let top_dir = takeDirectory (location (last flag_db_stack))
986 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
987 where toFields [] = return []
988 toFields (f:fs) = case toField f of
989 Nothing -> die ("unknown field: " ++ f)
990 Just fn -> do fns <- toFields fs
992 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
994 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
995 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
996 -- with the current topdir (obtained from the -B option).
997 mungePackagePaths top_dir ps = map munge_pkg ps
999 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
1000 includeDirs = munge_paths (includeDirs p),
1001 libraryDirs = munge_paths (libraryDirs p),
1002 frameworkDirs = munge_paths (frameworkDirs p),
1003 haddockInterfaces = munge_paths (haddockInterfaces p),
1004 haddockHTMLs = munge_paths (haddockHTMLs p)
1007 munge_paths = map munge_path
1010 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1011 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1014 toHttpPath p = "file:///" ++ p
1016 maybePrefixMatch :: String -> String -> Maybe String
1017 maybePrefixMatch [] rest = Just rest
1018 maybePrefixMatch (_:_) [] = Nothing
1019 maybePrefixMatch (p:pat) (r:rest)
1020 | p == r = maybePrefixMatch pat rest
1021 | otherwise = Nothing
1023 toField :: String -> Maybe (InstalledPackageInfo -> String)
1024 -- backwards compatibility:
1025 toField "import_dirs" = Just $ strList . importDirs
1026 toField "source_dirs" = Just $ strList . importDirs
1027 toField "library_dirs" = Just $ strList . libraryDirs
1028 toField "hs_libraries" = Just $ strList . hsLibraries
1029 toField "extra_libraries" = Just $ strList . extraLibraries
1030 toField "include_dirs" = Just $ strList . includeDirs
1031 toField "c_includes" = Just $ strList . includes
1032 toField "package_deps" = Just $ strList . map display. depends
1033 toField "extra_cc_opts" = Just $ strList . ccOptions
1034 toField "extra_ld_opts" = Just $ strList . ldOptions
1035 toField "framework_dirs" = Just $ strList . frameworkDirs
1036 toField "extra_frameworks"= Just $ strList . frameworks
1037 toField s = showInstalledPackageInfoField s
1039 strList :: [String] -> String
1043 -- -----------------------------------------------------------------------------
1044 -- Check: Check consistency of installed packages
1046 checkConsistency :: Verbosity -> [Flag] -> IO ()
1047 checkConsistency verbosity my_flags = do
1048 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1049 -- check behaves like modify for the purposes of deciding which
1050 -- databases to use, because ordering is important.
1052 let simple_output = FlagSimpleOutput `elem` my_flags
1054 let pkgs = allPackagesInStack db_stack
1057 (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1059 then do when (not simple_output) $ do
1060 _ <- reportValidateErrors [] ws "" Nothing
1064 when (not simple_output) $ do
1065 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1066 _ <- reportValidateErrors es ws " " Nothing
1070 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1072 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1073 where not_in p = sourcePackageId p `notElem` all_ps
1074 all_ps = map sourcePackageId pkgs1
1076 let not_broken_pkgs = filterOut broken_pkgs pkgs
1077 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1078 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1080 when (not (null all_broken_pkgs)) $ do
1082 then simplePackageList my_flags all_broken_pkgs
1084 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1085 "listed above, or because they depend on a broken package.")
1086 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1088 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1091 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1092 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1093 closure pkgs db_stack = go pkgs db_stack
1095 go avail not_avail =
1096 case partition (depsAvailable avail) not_avail of
1097 ([], not_avail') -> (avail, not_avail')
1098 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1100 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1102 depsAvailable pkgs_ok pkg = null dangling
1103 where dangling = filter (`notElem` pids) (depends pkg)
1104 pids = map installedPackageId pkgs_ok
1106 -- we want mutually recursive groups of package to show up
1107 -- as broken. (#1750)
1109 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1110 brokenPackages pkgs = snd (closure [] pkgs)
1112 -- -----------------------------------------------------------------------------
1113 -- Manipulating package.conf files
1115 type InstalledPackageInfoString = InstalledPackageInfo_ String
1117 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1118 convertPackageInfoOut
1119 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1120 hiddenModules = h })) =
1121 pkgconf{ exposedModules = map display e,
1122 hiddenModules = map display h }
1124 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1125 convertPackageInfoIn
1126 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1127 hiddenModules = h })) =
1128 pkgconf{ exposedModules = map convert e,
1129 hiddenModules = map convert h }
1130 where convert = fromJust . simpleParse
1132 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1133 writeNewConfig verbosity filename ipis = do
1134 when (verbosity >= Normal) $
1135 hPutStr stdout "Writing new package config file... "
1136 createDirectoryIfMissing True $ takeDirectory filename
1137 let shown = concat $ intersperse ",\n "
1138 $ map (show . convertPackageInfoOut) ipis
1139 fileContents = "[" ++ shown ++ "\n]"
1140 writeFileUtf8Atomic filename fileContents
1142 if isPermissionError e
1143 then die (filename ++ ": you don't have permission to modify this file")
1145 when (verbosity >= Normal) $
1146 hPutStrLn stdout "done."
1148 -----------------------------------------------------------------------------
1149 -- Sanity-check a new package config, and automatically build GHCi libs
1152 type ValidateError = (Force,String)
1153 type ValidateWarning = String
1155 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1157 instance Monad Validate where
1158 return a = V $ return (a, [], [])
1160 (a, es, ws) <- runValidate m
1161 (b, es', ws') <- runValidate (k a)
1162 return (b,es++es',ws++ws')
1164 verror :: Force -> String -> Validate ()
1165 verror f s = V (return ((),[(f,s)],[]))
1167 vwarn :: String -> Validate ()
1168 vwarn s = V (return ((),[],["Warning: " ++ s]))
1170 liftIO :: IO a -> Validate a
1171 liftIO k = V (k >>= \a -> return (a,[],[]))
1173 -- returns False if we should die
1174 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1175 -> String -> Maybe Force -> IO Bool
1176 reportValidateErrors es ws prefix mb_force = do
1177 mapM_ (warn . (prefix++)) ws
1178 oks <- mapM report es
1182 | Just force <- mb_force
1184 then do reportError (prefix ++ s ++ " (ignoring)")
1186 else if f < CannotForce
1187 then do reportError (prefix ++ s ++ " (use --force to override)")
1189 else do reportError err
1191 | otherwise = do reportError err
1196 validatePackageConfig :: InstalledPackageInfo
1198 -> Bool -- auto-ghc-libs
1199 -> Bool -- update, or check
1202 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1203 (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1204 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1205 when (not ok) $ exitWith (ExitFailure 1)
1207 checkPackageConfig :: InstalledPackageInfo
1209 -> Bool -- auto-ghc-libs
1210 -> Bool -- update, or check
1212 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1213 checkInstalledPackageId pkg db_stack update
1215 checkDuplicates db_stack pkg update
1216 mapM_ (checkDep db_stack) (depends pkg)
1217 checkDuplicateDepends (depends pkg)
1218 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1219 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1220 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1222 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1223 -- ToDo: check these somehow?
1224 -- extra_libraries :: [String],
1225 -- c_includes :: [String],
1227 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1229 checkInstalledPackageId ipi db_stack update = do
1230 let ipid@(InstalledPackageId str) = installedPackageId ipi
1231 when (null str) $ verror CannotForce "missing id field"
1232 let dups = [ p | p <- allPackagesInStack db_stack,
1233 installedPackageId p == ipid ]
1234 when (not update && not (null dups)) $
1235 verror CannotForce $
1236 "package(s) with this id already exist: " ++
1237 unwords (map (display.packageId) dups)
1239 -- When the package name and version are put together, sometimes we can
1240 -- end up with a package id that cannot be parsed. This will lead to
1241 -- difficulties when the user wants to refer to the package later, so
1242 -- we check that the package id can be parsed properly here.
1243 checkPackageId :: InstalledPackageInfo -> Validate ()
1244 checkPackageId ipi =
1245 let str = display (sourcePackageId ipi) in
1246 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1248 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1249 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1251 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1252 checkDuplicates db_stack pkg update = do
1254 pkgid = sourcePackageId pkg
1255 pkgs = packages (head db_stack)
1257 -- Check whether this package id already exists in this DB
1259 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1260 verror CannotForce $
1261 "package " ++ display pkgid ++ " is already installed"
1264 uncasep = map toLower . display
1265 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1267 when (not update && not (null dups)) $ verror ForceAll $
1268 "Package names may be treated case-insensitively in the future.\n"++
1269 "Package " ++ display pkgid ++
1270 " overlaps with: " ++ unwords (map display dups)
1273 checkDir :: Bool -> String -> String -> Validate ()
1274 checkDir warn_only thisfield d
1275 | "$topdir" `isPrefixOf` d = return ()
1276 | "$httptopdir" `isPrefixOf` d = return ()
1277 -- can't check these, because we don't know what $(http)topdir is
1278 | isRelative d = verror ForceFiles $
1279 thisfield ++ ": " ++ d ++ " is a relative path"
1280 -- relative paths don't make any sense; #4134
1282 there <- liftIO $ doesDirectoryExist d
1284 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
1288 else verror ForceFiles msg
1290 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1291 checkDep db_stack pkgid
1292 | pkgid `elem` pkgids = return ()
1293 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1294 ++ "\" doesn't exist")
1296 all_pkgs = allPackagesInStack db_stack
1297 pkgids = map installedPackageId all_pkgs
1299 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1300 checkDuplicateDepends deps
1301 | null dups = return ()
1302 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1303 unwords (map display dups))
1305 dups = [ p | (p:_:_) <- group (sort deps) ]
1307 checkHSLib :: [String] -> Bool -> String -> Validate ()
1308 checkHSLib dirs auto_ghci_libs lib = do
1309 let batch_lib_file = "lib" ++ lib ++ ".a"
1310 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1312 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1314 Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
1316 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1317 doesFileExistOnPath file path = go path
1318 where go [] = return Nothing
1319 go (p:ps) = do b <- doesFileExistIn file p
1320 if b then return (Just p) else go ps
1322 doesFileExistIn :: String -> String -> IO Bool
1323 doesFileExistIn lib d
1324 | "$topdir" `isPrefixOf` d = return True
1325 | "$httptopdir" `isPrefixOf` d = return True
1326 | otherwise = doesFileExist (d </> lib)
1328 checkModules :: InstalledPackageInfo -> Validate ()
1329 checkModules pkg = do
1330 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1332 findModule modl = do
1333 -- there's no .hi file for GHC.Prim
1334 if modl == fromString "GHC.Prim" then return () else do
1335 let file = toFilePath modl <.> "hi"
1336 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1337 when (isNothing m) $
1338 verror ForceFiles ("file " ++ file ++ " is missing")
1340 checkGHCiLib :: String -> String -> String -> Bool -> IO ()
1341 checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
1342 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1343 | otherwise = return ()
1345 ghci_lib_file = lib <.> "o"
1347 -- automatically build the GHCi version of a batch lib,
1348 -- using ld --whole-archive.
1350 autoBuildGHCiLib :: String -> String -> String -> IO ()
1351 autoBuildGHCiLib dir batch_file ghci_file = do
1352 let ghci_lib_file = dir ++ '/':ghci_file
1353 batch_lib_file = dir ++ '/':batch_file
1354 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1355 #if defined(darwin_HOST_OS)
1356 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1357 #elif defined(mingw32_HOST_OS)
1358 execDir <- getLibDir
1359 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1361 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1363 when (r /= ExitSuccess) $ exitWith r
1364 hPutStrLn stderr (" done.")
1366 -- -----------------------------------------------------------------------------
1367 -- Searching for modules
1371 findModules :: [FilePath] -> IO [String]
1373 mms <- mapM searchDir paths
1376 searchDir path prefix = do
1377 fs <- getDirectoryEntries path `catch` \_ -> return []
1378 searchEntries path prefix fs
1380 searchEntries path prefix [] = return []
1381 searchEntries path prefix (f:fs)
1382 | looks_like_a_module = do
1383 ms <- searchEntries path prefix fs
1384 return (prefix `joinModule` f : ms)
1385 | looks_like_a_component = do
1386 ms <- searchDir (path </> f) (prefix `joinModule` f)
1387 ms' <- searchEntries path prefix fs
1390 searchEntries path prefix fs
1393 (base,suffix) = splitFileExt f
1394 looks_like_a_module =
1395 suffix `elem` haskell_suffixes &&
1396 all okInModuleName base
1397 looks_like_a_component =
1398 null suffix && all okInModuleName base
1404 -- ---------------------------------------------------------------------------
1405 -- expanding environment variables in the package configuration
1407 expandEnvVars :: String -> Force -> IO String
1408 expandEnvVars str0 force = go str0 ""
1410 go "" acc = return $! reverse acc
1411 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1412 = do value <- lookupEnvVar var
1413 go rest (reverse value ++ acc)
1414 where close c = c == '}' || c == '\n' -- don't span newlines
1418 lookupEnvVar :: String -> IO String
1420 catch (System.Environment.getEnv nm)
1421 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1425 -----------------------------------------------------------------------------
1427 getProgramName :: IO String
1428 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1429 where str `withoutSuffix` suff
1430 | suff `isSuffixOf` str = take (length str - length suff) str
1433 bye :: String -> IO a
1434 bye s = putStr s >> exitWith ExitSuccess
1436 die :: String -> IO a
1439 dieWith :: Int -> String -> IO a
1442 prog <- getProgramName
1443 hPutStrLn stderr (prog ++ ": " ++ s)
1444 exitWith (ExitFailure ec)
1446 dieOrForceAll :: Force -> String -> IO ()
1447 dieOrForceAll ForceAll s = ignoreError s
1448 dieOrForceAll _other s = dieForcible s
1450 warn :: String -> IO ()
1453 ignoreError :: String -> IO ()
1454 ignoreError s = reportError (s ++ " (ignoring)")
1456 reportError :: String -> IO ()
1457 reportError s = do hFlush stdout; hPutStrLn stderr s
1459 dieForcible :: String -> IO ()
1460 dieForcible s = die (s ++ " (use --force to override)")
1462 my_head :: String -> [a] -> a
1463 my_head s [] = error s
1464 my_head _ (x : _) = x
1466 -----------------------------------------
1467 -- Cut and pasted from ghc/compiler/main/SysTools
1469 #if defined(mingw32_HOST_OS)
1470 subst :: Char -> Char -> String -> String
1471 subst a b ls = map (\ x -> if x == a then b else x) ls
1473 unDosifyPath :: FilePath -> FilePath
1474 unDosifyPath xs = subst '\\' '/' xs
1476 getLibDir :: IO (Maybe String)
1477 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1479 -- (getExecDir cmd) returns the directory in which the current
1480 -- executable, which should be called 'cmd', is running
1481 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1482 -- you'll get "/a/b/c" back as the result
1483 getExecDir :: String -> IO (Maybe String)
1485 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1486 where initN n = reverse . drop n . reverse
1487 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1489 getExecPath :: IO (Maybe String)
1491 allocaArray len $ \buf -> do
1492 ret <- getModuleFileName nullPtr buf len
1493 if ret == 0 then return Nothing
1494 else liftM Just $ peekCString buf
1495 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1497 foreign import stdcall unsafe "GetModuleFileNameA"
1498 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1501 getLibDir :: IO (Maybe String)
1502 getLibDir = return Nothing
1505 -----------------------------------------
1506 -- Adapted from ghc/compiler/utils/Panic
1508 installSignalHandlers :: IO ()
1509 installSignalHandlers = do
1510 threadid <- myThreadId
1512 interrupt = Exception.throwTo threadid
1513 (Exception.ErrorCall "interrupted")
1515 #if !defined(mingw32_HOST_OS)
1516 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1517 _ <- installHandler sigINT (Catch interrupt) Nothing
1520 -- GHC 6.3+ has support for console events on Windows
1521 -- NOTE: running GHCi under a bash shell for some reason requires
1522 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1523 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1524 -- why --SDM 17/12/2004
1525 let sig_handler ControlC = interrupt
1526 sig_handler Break = interrupt
1527 sig_handler _ = return ()
1529 _ <- installHandler (Catch sig_handler)
1533 #if mingw32_HOST_OS || mingw32_TARGET_OS
1534 throwIOIO :: Exception.IOException -> IO a
1535 throwIOIO = Exception.throwIO
1537 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1538 catchIO = Exception.catch
1541 catchError :: IO a -> (String -> IO a) -> IO a
1542 catchError io handler = io `Exception.catch` handler'
1543 where handler' (Exception.ErrorCall err) = handler err
1546 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1547 writeBinaryFileAtomic targetFile obj =
1548 withFileAtomic targetFile $ \h -> do
1549 hSetBinaryMode h True
1550 B.hPutStr h (Bin.encode obj)
1552 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1553 writeFileUtf8Atomic targetFile content =
1554 withFileAtomic targetFile $ \h -> do
1558 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1559 -- to use text files here, rather than binary files.
1560 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1561 withFileAtomic targetFile write_content = do
1562 (newFile, newHandle) <- openNewFile targetDir template
1563 do write_content newHandle
1565 #if mingw32_HOST_OS || mingw32_TARGET_OS
1566 renameFile newFile targetFile
1567 -- If the targetFile exists then renameFile will fail
1568 `catchIO` \err -> do
1569 exists <- doesFileExist targetFile
1571 then do removeFileSafe targetFile
1572 -- Big fat hairy race condition
1573 renameFile newFile targetFile
1574 -- If the removeFile succeeds and the renameFile fails
1575 -- then we've lost the atomic property.
1578 renameFile newFile targetFile
1580 `Exception.onException` do hClose newHandle
1581 removeFileSafe newFile
1583 template = targetName <.> "tmp"
1584 targetDir | null targetDir_ = "."
1585 | otherwise = targetDir_
1586 --TODO: remove this when takeDirectory/splitFileName is fixed
1587 -- to always return a valid dir
1588 (targetDir_,targetName) = splitFileName targetFile
1590 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1591 openNewFile dir template = do
1592 -- this was added to System.IO in 6.12.1
1593 -- we must use this version because the version below opens the file
1595 openTempFileWithDefaultPermissions dir template
1597 -- | The function splits the given string to substrings
1598 -- using 'isSearchPathSeparator'.
1599 parseSearchPath :: String -> [FilePath]
1600 parseSearchPath path = split path
1602 split :: String -> [String]
1606 _:rest -> chunk : split rest
1610 #ifdef mingw32_HOST_OS
1611 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1615 (chunk', rest') = break isSearchPathSeparator s
1617 readUTF8File :: FilePath -> IO String
1618 readUTF8File file = do
1619 h <- openFile file ReadMode
1620 -- fix the encoding to UTF-8
1624 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1625 removeFileSafe :: FilePath -> IO ()
1627 removeFile fn `catch` \ e ->
1628 when (not $ isDoesNotExistError e) $ ioError e