1 {-# OPTIONS -fglasgow-exts -cpp #-}
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 #include "../../includes/ghcconfig.h"
32 import System.Console.GetOpt
33 #if __GLASGOW_HASKELL__ >= 609
34 import qualified Control.Exception as Exception
36 import qualified Control.Exception.Extensible as Exception
40 import Data.Char ( isSpace, toLower )
42 import System.Directory ( doesDirectoryExist, getDirectoryContents,
43 doesFileExist, renameFile, removeFile )
44 import System.Exit ( exitWith, ExitCode(..) )
45 import System.Environment ( getArgs, getProgName, getEnv )
47 import System.IO.Error (try)
49 import Control.Concurrent
53 #ifdef mingw32_HOST_OS
54 import GHC.ConsoleHandler
56 import System.Posix hiding (fdToHandle)
59 import IO ( isPermissionError )
60 import System.Posix.Internals
61 #if __GLASGOW_HASKELL__ >= 611
62 import GHC.IO.Handle.FD (fdToHandle)
64 import GHC.Handle (fdToHandle)
68 import System.Process(runInteractiveCommand)
69 import qualified System.Info(os)
72 #if __GLASGOW_HASKELL__ >= 611
73 import System.Console.Terminfo as Terminfo
76 -- -----------------------------------------------------------------------------
83 case getOpt Permute (flags ++ deprecFlags) args of
84 (cli,_,[]) | FlagHelp `elem` cli -> do
85 prog <- getProgramName
86 bye (usageInfo (usageHeader prog) flags)
87 (cli,_,[]) | FlagVersion `elem` cli ->
90 case getVerbosity Normal cli of
91 Right v -> runit v cli nonopts
94 prog <- getProgramName
95 die (concat errors ++ usageInfo (usageHeader prog) flags)
97 -- -----------------------------------------------------------------------------
98 -- Command-line syntax
105 | FlagConfig FilePath
106 | FlagGlobalConfig FilePath
114 | FlagVerbosity (Maybe String)
117 flags :: [OptDescr Flag]
119 Option [] ["user"] (NoArg FlagUser)
120 "use the current user's package database",
121 Option [] ["global"] (NoArg FlagGlobal)
122 "use the global package database",
123 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
124 "use the specified package config file",
125 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
126 "location of the global package config",
127 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
128 "never read the user package database",
129 Option [] ["force"] (NoArg FlagForce)
130 "ignore missing dependencies, directories, and libraries",
131 Option [] ["force-files"] (NoArg FlagForceFiles)
132 "ignore missing directories and libraries only",
133 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
134 "automatically build libs for GHCi (with register)",
135 Option ['?'] ["help"] (NoArg FlagHelp)
136 "display this help and exit",
137 Option ['V'] ["version"] (NoArg FlagVersion)
138 "output version information and exit",
139 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
140 "print output in easy-to-parse format for some commands",
141 Option [] ["names-only"] (NoArg FlagNamesOnly)
142 "only print package names, not versions; can only be used with list --simple-output",
143 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
144 "ignore case for substring matching",
145 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
146 "verbosity level (0-2, default 1)"
149 data Verbosity = Silent | Normal | Verbose
150 deriving (Show, Eq, Ord)
152 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
153 getVerbosity v [] = Right v
154 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
155 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
156 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
157 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
158 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
159 getVerbosity v (_ : fs) = getVerbosity v fs
161 deprecFlags :: [OptDescr Flag]
163 -- put deprecated flags here
166 ourCopyright :: String
167 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
169 usageHeader :: String -> String
170 usageHeader prog = substProg prog $
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.\n" ++
177 " $p update {filename | -}\n" ++
178 " Register the package, overwriting any other package with the\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.\n" ++
228 " Substring matching is supported for {module} in find-module and\n" ++
229 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
230 " open substring ends (prefix*, *suffix, *infix*).\n" ++
232 " When asked to modify a database (register, unregister, update,\n"++
233 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
234 " default. Specifying --user causes it to act on the user database,\n"++
235 " or --package-conf can be used to act on another database\n"++
236 " entirely. When multiple of these options are given, the rightmost\n"++
237 " one is used as the database to act upon.\n"++
239 " Commands that query the package database (list, tree, latest, describe,\n"++
240 " field) operate on the list of databases specified by the flags\n"++
241 " --user, --global, and --package-conf. If none of these flags are\n"++
242 " given, the default is --global --user.\n"++
244 " The following optional flags are also accepted:\n"
246 substProg :: String -> String -> String
248 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
249 substProg prog (c:xs) = c : substProg prog xs
251 -- -----------------------------------------------------------------------------
254 data Force = NoForce | ForceFiles | ForceAll | CannotForce
257 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
259 runit :: Verbosity -> [Flag] -> [String] -> IO ()
260 runit verbosity cli nonopts = do
261 installSignalHandlers -- catch ^C and clean up
262 prog <- getProgramName
265 | FlagForce `elem` cli = ForceAll
266 | FlagForceFiles `elem` cli = ForceFiles
267 | otherwise = NoForce
268 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
269 splitFields fields = unfoldr splitComma (',':fields)
270 where splitComma "" = Nothing
271 splitComma fs = Just $ break (==',') (tail fs)
273 substringCheck :: String -> Maybe (String -> Bool)
274 substringCheck "" = Nothing
275 substringCheck "*" = Just (const True)
276 substringCheck [_] = Nothing
277 substringCheck (h:t) =
278 case (h, init t, last t) of
279 ('*',s,'*') -> Just (isInfixOf (f s) . f)
280 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
281 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
283 where f | FlagIgnoreCase `elem` cli = map toLower
286 glob x | System.Info.os=="mingw32" = do
287 -- glob echoes its argument, after win32 filename globbing
288 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
289 txt <- hGetContents o
291 glob x | otherwise = return [x]
294 -- first, parse the command
297 -- dummy command to demonstrate usage and permit testing
298 -- without messing things up; use glob to selectively enable
299 -- windows filename globbing for file parameters
300 -- register, update, FlagGlobalConfig, FlagConfig; others?
301 ["glob", filename] -> do
303 glob filename >>= print
305 ["register", filename] ->
306 registerPackage filename verbosity cli auto_ghci_libs False force
307 ["update", filename] ->
308 registerPackage filename verbosity cli auto_ghci_libs True force
309 ["unregister", pkgid_str] -> do
310 pkgid <- readGlobPkgId pkgid_str
311 unregisterPackage pkgid verbosity cli force
312 ["expose", pkgid_str] -> do
313 pkgid <- readGlobPkgId pkgid_str
314 exposePackage pkgid verbosity cli force
315 ["hide", pkgid_str] -> do
316 pkgid <- readGlobPkgId pkgid_str
317 hidePackage pkgid verbosity cli force
319 listPackages verbosity cli Nothing Nothing
320 ["list", pkgid_str] ->
321 case substringCheck pkgid_str of
322 Nothing -> do pkgid <- readGlobPkgId pkgid_str
323 listPackages verbosity cli (Just (Id pkgid)) Nothing
324 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
326 showPackageDot verbosity cli
327 ["find-module", moduleName] -> do
328 let match = maybe (==moduleName) id (substringCheck moduleName)
329 listPackages verbosity cli Nothing (Just match)
330 ["latest", pkgid_str] -> do
331 pkgid <- readGlobPkgId pkgid_str
332 latestPackage verbosity cli pkgid
333 ["describe", pkgid_str] ->
334 case substringCheck pkgid_str of
335 Nothing -> do pkgid <- readGlobPkgId pkgid_str
336 describePackage verbosity cli (Id pkgid)
337 Just m -> describePackage verbosity cli (Substring pkgid_str m)
338 ["field", pkgid_str, fields] ->
339 case substringCheck pkgid_str of
340 Nothing -> do pkgid <- readGlobPkgId pkgid_str
341 describeField verbosity cli (Id pkgid)
343 Just m -> describeField verbosity cli (Substring pkgid_str m)
346 checkConsistency verbosity cli
349 dumpPackages verbosity cli
352 recache verbosity cli
355 die ("missing command\n" ++
356 usageInfo (usageHeader prog) flags)
358 die ("command-line syntax error\n" ++
359 usageInfo (usageHeader prog) flags)
361 parseCheck :: ReadP a a -> String -> String -> IO a
362 parseCheck parser str what =
363 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
365 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
367 readGlobPkgId :: String -> IO PackageIdentifier
368 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
370 parseGlobPackageId :: ReadP r PackageIdentifier
376 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
378 -- globVersion means "all versions"
379 globVersion :: Version
380 globVersion = Version{ versionBranch=[], versionTags=["*"] }
382 -- -----------------------------------------------------------------------------
385 -- Some commands operate on a single database:
386 -- register, unregister, expose, hide
387 -- however these commands also check the union of the available databases
388 -- in order to check consistency. For example, register will check that
389 -- dependencies exist before registering a package.
391 -- Some commands operate on multiple databases, with overlapping semantics:
392 -- list, describe, field
395 = PackageDB { location :: FilePath,
396 packages :: [InstalledPackageInfo] }
398 type PackageDBStack = [PackageDB]
399 -- A stack of package databases. Convention: head is the topmost
402 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
403 allPackagesInStack = concatMap packages
405 getPkgDatabases :: Verbosity
406 -> Bool -- we are modifying, not reading
407 -> Bool -- read caches, if available
409 -> IO (PackageDBStack,
410 -- the real package DB stack: [global,user] ++
411 -- DBs specified on the command line with -f.
413 -- which one to modify, if any
415 -- the package DBs specified on the command
416 -- line, or [global,user] otherwise. This
417 -- is used as the list of package DBs for
418 -- commands that just read the DB, such as 'list'.
420 getPkgDatabases verbosity modify use_cache my_flags = do
421 -- first we determine the location of the global package config. On Windows,
422 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
423 -- location is passed to the binary using the --global-config flag by the
425 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
427 case [ f | FlagGlobalConfig f <- my_flags ] of
428 [] -> do mb_dir <- getLibDir
430 Nothing -> die err_msg
432 r <- lookForPackageDBIn dir
434 Nothing -> die ("Can't find package database in " ++ dir)
435 Just path -> return path
436 fs -> return (last fs)
438 let no_user_db = FlagNoUserDb `elem` my_flags
440 -- get the location of the user package database, and create it if necessary
441 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
442 e_appdir <- try $ getAppUserDataDirectory "ghc"
445 if no_user_db then return Nothing else
447 Left _ -> return Nothing
449 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
450 dir = appdir </> subdir
451 r <- lookForPackageDBIn dir
453 Nothing -> return (Just (dir </> "package.conf.d", False))
454 Just f -> return (Just (f, True))
456 -- If the user database doesn't exist, and this command isn't a
457 -- "modify" command, then we won't attempt to create or use it.
459 | Just (user_conf,user_exists) <- mb_user_conf,
460 modify || user_exists = [user_conf, global_conf]
461 | otherwise = [global_conf]
463 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
466 Left _ -> sys_databases
468 | last cs == "" -> init cs ++ sys_databases
470 where cs = parseSearchPath path
472 -- The "global" database is always the one at the bottom of the stack.
473 -- This is the database we modify by default.
474 virt_global_conf = last env_stack
476 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
477 where is_db_flag FlagUser
478 | Just (user_conf, _user_exists) <- mb_user_conf
480 is_db_flag FlagGlobal = Just virt_global_conf
481 is_db_flag (FlagConfig f) = Just f
482 is_db_flag _ = Nothing
484 let flag_db_names | null db_flags = env_stack
485 | otherwise = reverse (nub db_flags)
487 -- For a "modify" command, treat all the databases as
488 -- a stack, where we are modifying the top one, but it
489 -- can refer to packages in databases further down the
492 -- -f flags on the command line add to the database
493 -- stack, unless any of them are present in the stack
495 let final_stack = filter (`notElem` env_stack)
496 [ f | FlagConfig f <- reverse my_flags ]
499 -- the database we actually modify is the one mentioned
500 -- rightmost on the command-line.
502 | not modify = Nothing
503 | null db_flags = Just virt_global_conf
504 | otherwise = Just (last db_flags)
506 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
508 let flag_db_stack = [ db | db_name <- flag_db_names,
509 db <- db_stack, location db == db_name ]
511 return (db_stack, to_modify, flag_db_stack)
514 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
515 lookForPackageDBIn dir = do
516 let path_dir = dir </> "package.conf.d"
517 exists_dir <- doesDirectoryExist path_dir
518 if exists_dir then return (Just path_dir) else do
519 let path_file = dir </> "package.conf"
520 exists_file <- doesFileExist path_file
521 if exists_file then return (Just path_file) else return Nothing
523 readParseDatabase :: Verbosity
524 -> Maybe (FilePath,Bool)
529 readParseDatabase verbosity mb_user_conf use_cache path
530 -- the user database (only) is allowed to be non-existent
531 | Just (user_conf,False) <- mb_user_conf, path == user_conf
532 = return PackageDB { location = path, packages = [] }
534 = do e <- try $ getDirectoryContents path
537 pkgs <- parseMultiPackageConf verbosity path
538 return PackageDB{ location = path, packages = pkgs }
540 | not use_cache -> ignore_cache
542 let cache = path </> cachefilename
543 tdir <- getModificationTime path
544 e_tcache <- try $ getModificationTime cache
547 when (verbosity > Normal) $
548 putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
551 | tcache >= tdir -> do
552 when (verbosity > Normal) $
553 putStrLn ("using cache: " ++ cache)
554 pkgs <- readBinPackageDB cache
555 let pkgs' = map convertPackageInfoIn pkgs
556 return PackageDB { location = path, packages = pkgs' }
558 when (verbosity >= Normal) $ do
559 putStrLn ("WARNING: cache is out of date: " ++ cache)
560 putStrLn " use 'ghc-pkg recache' to fix."
564 let confs = filter (".conf" `isSuffixOf`) fs
565 pkgs <- mapM (parseSingletonPackageConf verbosity) $
567 return PackageDB { location = path, packages = pkgs }
570 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
571 parseMultiPackageConf verbosity file = do
572 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
574 let pkgs = map convertPackageInfoIn $ read str
575 Exception.evaluate pkgs
577 die ("error while parsing " ++ file ++ ": " ++ show e)
579 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
580 parseSingletonPackageConf verbosity file = do
581 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
582 readFile file >>= parsePackageInfo
584 cachefilename :: FilePath
585 cachefilename = "package.cache"
587 -- -----------------------------------------------------------------------------
590 registerPackage :: FilePath
593 -> Bool -- auto_ghci_libs
597 registerPackage input verbosity my_flags auto_ghci_libs update force = do
598 (db_stack, Just to_modify, _flag_dbs) <-
599 getPkgDatabases verbosity True True my_flags
602 db_to_operate_on = my_head "register" $
603 filter ((== to_modify).location) db_stack
608 when (verbosity >= Normal) $
609 putStr "Reading package info from stdin ... "
612 when (verbosity >= Normal) $
613 putStr ("Reading package info from " ++ show f ++ " ... ")
616 expanded <- expandEnvVars s force
618 pkg <- parsePackageInfo expanded
619 when (verbosity >= Normal) $
622 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
623 -- truncate the stack for validation, because we don't allow
624 -- packages lower in the stack to refer to those higher up.
625 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
627 removes = [ RemovePackage p
628 | p <- packages db_to_operate_on,
629 sourcePackageId p == sourcePackageId pkg ]
631 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
635 -> IO InstalledPackageInfo
636 parsePackageInfo str =
637 case parseInstalledPackageInfo str of
638 ParseOk _warns ok -> return ok
639 ParseFailed err -> case locatedErrorMsg err of
640 (Nothing, s) -> die s
641 (Just l, s) -> die (show l ++ ": " ++ s)
643 -- -----------------------------------------------------------------------------
644 -- Making changes to a package database
646 data DBOp = RemovePackage InstalledPackageInfo
647 | AddPackage InstalledPackageInfo
648 | ModifyPackage InstalledPackageInfo
650 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
651 changeDB verbosity cmds db = do
652 let db' = updateInternalDB db cmds
653 isfile <- doesFileExist (location db)
655 then writeNewConfig verbosity (location db') (packages db')
657 createDirectoryIfMissing True (location db)
658 changeDBDir verbosity cmds db'
660 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
661 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
663 do_cmd pkgs (RemovePackage p) =
664 filter ((/= installedPackageId p) . installedPackageId) pkgs
665 do_cmd pkgs (AddPackage p) = p : pkgs
666 do_cmd pkgs (ModifyPackage p) =
667 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
670 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
671 changeDBDir verbosity cmds db = do
673 updateDBCache verbosity db
675 do_cmd (RemovePackage p) = do
676 let file = location db </> display (installedPackageId p) <.> "conf"
677 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
679 do_cmd (AddPackage p) = do
680 let file = location db </> display (installedPackageId p) <.> "conf"
681 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
682 writeFileAtomic file (showInstalledPackageInfo p)
683 do_cmd (ModifyPackage p) =
684 do_cmd (AddPackage p)
686 updateDBCache :: Verbosity -> PackageDB -> IO ()
687 updateDBCache verbosity db = do
688 let filename = location db </> cachefilename
689 when (verbosity > Normal) $
690 putStrLn ("writing cache " ++ filename)
691 writeBinPackageDB filename (map convertPackageInfoOut (packages db))
693 if isPermissionError e
694 then die (filename ++ ": you don't have permission to modify this file")
697 -- -----------------------------------------------------------------------------
698 -- Exposing, Hiding, Unregistering are all similar
700 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
701 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
703 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
704 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
706 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
707 unregisterPackage = modifyPackage RemovePackage
710 :: (InstalledPackageInfo -> DBOp)
716 modifyPackage fn pkgid verbosity my_flags force = do
717 (db_stack, Just _to_modify, _flag_dbs) <-
718 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
720 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
722 db_name = location db
725 pids = map sourcePackageId ps
727 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
728 new_db = updateInternalDB db cmds
730 old_broken = brokenPackages (allPackagesInStack db_stack)
731 rest_of_stack = filter ((/= db_name) . location) db_stack
732 new_stack = new_db : rest_of_stack
733 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
734 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
736 when (not (null newly_broken)) $
737 dieOrForceAll force ("unregistering " ++ display pkgid ++
738 " would break the following packages: "
739 ++ unwords (map display newly_broken))
741 changeDB verbosity cmds db
743 recache :: Verbosity -> [Flag] -> IO ()
744 recache verbosity my_flags = do
745 (db_stack, Just to_modify, _flag_dbs) <-
746 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
748 db_to_operate_on = my_head "recache" $
749 filter ((== to_modify).location) db_stack
751 changeDB verbosity [] db_to_operate_on
753 -- -----------------------------------------------------------------------------
756 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
757 -> Maybe (String->Bool)
759 listPackages verbosity my_flags mPackageName mModuleName = do
760 let simple_output = FlagSimpleOutput `elem` my_flags
761 (db_stack, _, flag_db_stack) <-
762 getPkgDatabases verbosity False True{-use cache-} my_flags
764 let db_stack_filtered -- if a package is given, filter out all other packages
765 | Just this <- mPackageName =
766 [ db{ packages = filter (this `matchesPkg`) (packages db) }
767 | db <- flag_db_stack ]
768 | Just match <- mModuleName = -- packages which expose mModuleName
769 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
770 | db <- flag_db_stack ]
771 | otherwise = flag_db_stack
774 = [ db{ packages = sort_pkgs (packages db) }
775 | db <- db_stack_filtered ]
776 where sort_pkgs = sortBy cmpPkgIds
777 cmpPkgIds pkg1 pkg2 =
778 case pkgName p1 `compare` pkgName p2 of
781 EQ -> pkgVersion p1 `compare` pkgVersion p2
782 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
784 stack = reverse db_stack_sorted
786 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
788 pkg_map = allPackagesInStack db_stack
789 broken = map sourcePackageId (brokenPackages pkg_map)
791 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
792 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
794 pp_pkgs = map pp_pkg pkg_confs
796 | sourcePackageId p `elem` broken = printf "{%s}" doc
798 | otherwise = printf "(%s)" doc
799 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
802 InstalledPackageId ipid = installedPackageId p
803 pkg = display (sourcePackageId p)
805 show_simple = simplePackageList my_flags . allPackagesInStack
807 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
808 prog <- getProgramName
809 putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
811 if simple_output then show_simple stack else do
813 #if __GLASGOW_HASKELL__ < 611
814 mapM_ show_normal stack
817 show_colour withF db =
818 mconcat $ map (<#> termText "\n") $
819 (termText (location db) :
820 map (termText " " <#>) (map pp_pkg (packages db)))
823 | sourcePackageId p `elem` broken = withF Red doc
825 | otherwise = withF Blue doc
826 where doc | verbosity >= Verbose
827 = termText (printf "%s (%s)" pkg ipid)
831 InstalledPackageId ipid = installedPackageId p
832 pkg = display (sourcePackageId p)
834 is_tty <- hIsTerminalDevice stdout
836 then mapM_ show_normal stack
837 else do tty <- Terminfo.setupTermFromEnv
838 case Terminfo.getCapability tty withForegroundColor of
839 Nothing -> mapM_ show_normal stack
840 Just w -> runTermOutput tty $ mconcat $
841 map (show_colour w) stack
844 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
845 simplePackageList my_flags pkgs = do
846 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
848 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
849 when (not (null pkgs)) $
850 hPutStrLn stdout $ concat $ intersperse " " strs
852 showPackageDot :: Verbosity -> [Flag] -> IO ()
853 showPackageDot verbosity myflags = do
854 (_, _, flag_db_stack) <-
855 getPkgDatabases verbosity False True{-use cache-} myflags
857 let all_pkgs = allPackagesInStack flag_db_stack
858 ipix = PackageIndex.listToInstalledPackageIndex all_pkgs
861 let quote s = '"':s ++ "\""
862 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
864 let from = display (sourcePackageId p),
866 Just dep <- [PackageIndex.lookupInstalledPackage ipix depid],
867 let to = display (sourcePackageId dep)
871 -- -----------------------------------------------------------------------------
872 -- Prints the highest (hidden or exposed) version of a package
874 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
875 latestPackage verbosity my_flags pkgid = do
876 (_, _, flag_db_stack) <-
877 getPkgDatabases verbosity False True{-use cache-} my_flags
879 ps <- findPackages flag_db_stack (Id pkgid)
880 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
882 show_pkg [] = die "no matches"
883 show_pkg pids = hPutStrLn stdout (display (last pids))
885 -- -----------------------------------------------------------------------------
888 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
889 describePackage verbosity my_flags pkgarg = do
890 (_, _, flag_db_stack) <-
891 getPkgDatabases verbosity False True{-use cache-} my_flags
892 ps <- findPackages flag_db_stack pkgarg
895 dumpPackages :: Verbosity -> [Flag] -> IO ()
896 dumpPackages verbosity my_flags = do
897 (_, _, flag_db_stack) <-
898 getPkgDatabases verbosity False True{-use cache-} my_flags
899 doDump (allPackagesInStack flag_db_stack)
901 doDump :: [InstalledPackageInfo] -> IO ()
902 doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
904 -- PackageId is can have globVersion for the version
905 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
906 findPackages db_stack pkgarg
907 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
909 findPackagesByDB :: PackageDBStack -> PackageArg
910 -> IO [(PackageDB, [InstalledPackageInfo])]
911 findPackagesByDB db_stack pkgarg
912 = case [ (db, matched)
914 let matched = filter (pkgarg `matchesPkg`) (packages db),
915 not (null matched) ] of
916 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
919 pkg_msg (Id pkgid) = display pkgid
920 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
922 matches :: PackageIdentifier -> PackageIdentifier -> Bool
924 = (pkgName pid == pkgName pid')
925 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
927 realVersion :: PackageIdentifier -> Bool
928 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
929 -- when versionBranch == [], this is a glob
931 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
932 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
933 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
935 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
936 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
938 -- -----------------------------------------------------------------------------
941 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
942 describeField verbosity my_flags pkgarg fields = do
943 (_, _, flag_db_stack) <-
944 getPkgDatabases verbosity False True{-use cache-} my_flags
945 fns <- toFields fields
946 ps <- findPackages flag_db_stack pkgarg
947 let top_dir = takeDirectory (location (last flag_db_stack))
948 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
949 where toFields [] = return []
950 toFields (f:fs) = case toField f of
951 Nothing -> die ("unknown field: " ++ f)
952 Just fn -> do fns <- toFields fs
954 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
956 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
957 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
958 -- with the current topdir (obtained from the -B option).
959 mungePackagePaths top_dir ps = map munge_pkg ps
961 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
962 includeDirs = munge_paths (includeDirs p),
963 libraryDirs = munge_paths (libraryDirs p),
964 frameworkDirs = munge_paths (frameworkDirs p),
965 haddockInterfaces = munge_paths (haddockInterfaces p),
966 haddockHTMLs = munge_paths (haddockHTMLs p)
969 munge_paths = map munge_path
972 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
973 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
976 toHttpPath p = "file:///" ++ p
978 maybePrefixMatch :: String -> String -> Maybe String
979 maybePrefixMatch [] rest = Just rest
980 maybePrefixMatch (_:_) [] = Nothing
981 maybePrefixMatch (p:pat) (r:rest)
982 | p == r = maybePrefixMatch pat rest
983 | otherwise = Nothing
985 toField :: String -> Maybe (InstalledPackageInfo -> String)
986 -- backwards compatibility:
987 toField "import_dirs" = Just $ strList . importDirs
988 toField "source_dirs" = Just $ strList . importDirs
989 toField "library_dirs" = Just $ strList . libraryDirs
990 toField "hs_libraries" = Just $ strList . hsLibraries
991 toField "extra_libraries" = Just $ strList . extraLibraries
992 toField "include_dirs" = Just $ strList . includeDirs
993 toField "c_includes" = Just $ strList . includes
994 toField "package_deps" = Just $ strList . map display. depends
995 toField "extra_cc_opts" = Just $ strList . ccOptions
996 toField "extra_ld_opts" = Just $ strList . ldOptions
997 toField "framework_dirs" = Just $ strList . frameworkDirs
998 toField "extra_frameworks"= Just $ strList . frameworks
999 toField s = showInstalledPackageInfoField s
1001 strList :: [String] -> String
1005 -- -----------------------------------------------------------------------------
1006 -- Check: Check consistency of installed packages
1008 checkConsistency :: Verbosity -> [Flag] -> IO ()
1009 checkConsistency verbosity my_flags = do
1010 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1011 -- check behaves like modify for the purposes of deciding which
1012 -- databases to use, because ordering is important.
1014 let simple_output = FlagSimpleOutput `elem` my_flags
1016 let pkgs = allPackagesInStack db_stack
1019 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
1023 when (not simple_output) $ do
1024 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1025 _ <- reportValidateErrors es " " Nothing
1029 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1031 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1032 where not_in p = sourcePackageId p `notElem` all_ps
1033 all_ps = map sourcePackageId pkgs1
1035 let not_broken_pkgs = filterOut broken_pkgs pkgs
1036 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1037 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1039 when (not (null all_broken_pkgs)) $ do
1041 then simplePackageList my_flags all_broken_pkgs
1043 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1044 "listed above, or because they depend on a broken package.")
1045 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1047 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1050 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1051 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1052 closure pkgs db_stack = go pkgs db_stack
1054 go avail not_avail =
1055 case partition (depsAvailable avail) not_avail of
1056 ([], not_avail') -> (avail, not_avail')
1057 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1059 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1061 depsAvailable pkgs_ok pkg = null dangling
1062 where dangling = filter (`notElem` pids) (depends pkg)
1063 pids = map installedPackageId pkgs_ok
1065 -- we want mutually recursive groups of package to show up
1066 -- as broken. (#1750)
1068 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1069 brokenPackages pkgs = snd (closure [] pkgs)
1071 -- -----------------------------------------------------------------------------
1072 -- Manipulating package.conf files
1074 type InstalledPackageInfoString = InstalledPackageInfo_ String
1076 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1077 convertPackageInfoOut
1078 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1079 hiddenModules = h })) =
1080 pkgconf{ exposedModules = map display e,
1081 hiddenModules = map display h }
1083 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1084 convertPackageInfoIn
1085 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1086 hiddenModules = h })) =
1087 pkgconf{ exposedModules = map convert e,
1088 hiddenModules = map convert h }
1089 where convert = fromJust . simpleParse
1091 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1092 writeNewConfig verbosity filename ipis = do
1093 when (verbosity >= Normal) $
1094 hPutStr stdout "Writing new package config file... "
1095 createDirectoryIfMissing True $ takeDirectory filename
1096 let shown = concat $ intersperse ",\n "
1097 $ map (show . convertPackageInfoOut) ipis
1098 fileContents = "[" ++ shown ++ "\n]"
1099 writeFileAtomic filename fileContents
1101 if isPermissionError e
1102 then die (filename ++ ": you don't have permission to modify this file")
1104 when (verbosity >= Normal) $
1105 hPutStrLn stdout "done."
1107 -----------------------------------------------------------------------------
1108 -- Sanity-check a new package config, and automatically build GHCi libs
1111 type ValidateError = (Force,String)
1113 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
1115 instance Monad Validate where
1116 return a = V $ return (a, [])
1118 (a, es) <- runValidate m
1119 (b, es') <- runValidate (k a)
1122 verror :: Force -> String -> Validate ()
1123 verror f s = V (return ((),[(f,s)]))
1125 liftIO :: IO a -> Validate a
1126 liftIO k = V (k >>= \a -> return (a,[]))
1128 -- returns False if we should die
1129 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
1130 reportValidateErrors es prefix mb_force = do
1131 oks <- mapM report es
1135 | Just force <- mb_force
1137 then do reportError (prefix ++ s ++ " (ignoring)")
1139 else if f < CannotForce
1140 then do reportError (prefix ++ s ++ " (use --force to override)")
1142 else do reportError err
1144 | otherwise = do reportError err
1149 validatePackageConfig :: InstalledPackageInfo
1151 -> Bool -- auto-ghc-libs
1152 -> Bool -- update, or check
1155 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1156 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1157 ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
1158 when (not ok) $ exitWith (ExitFailure 1)
1160 checkPackageConfig :: InstalledPackageInfo
1162 -> Bool -- auto-ghc-libs
1163 -> Bool -- update, or check
1165 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1166 checkInstalledPackageId pkg db_stack update
1168 checkDuplicates db_stack pkg update
1169 mapM_ (checkDep db_stack) (depends pkg)
1170 checkDuplicateDepends (depends pkg)
1171 mapM_ (checkDir "import-dirs") (importDirs pkg)
1172 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
1173 mapM_ (checkDir "include-dirs") (includeDirs pkg)
1175 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1176 -- ToDo: check these somehow?
1177 -- extra_libraries :: [String],
1178 -- c_includes :: [String],
1180 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1182 checkInstalledPackageId ipi db_stack update = do
1183 let ipid@(InstalledPackageId str) = installedPackageId ipi
1184 when (null str) $ verror CannotForce "missing id field"
1185 let dups = [ p | p <- allPackagesInStack db_stack,
1186 installedPackageId p == ipid ]
1187 when (not update && not (null dups)) $
1188 verror CannotForce $
1189 "package(s) with this id already exist: " ++
1190 unwords (map (display.packageId) dups)
1192 -- When the package name and version are put together, sometimes we can
1193 -- end up with a package id that cannot be parsed. This will lead to
1194 -- difficulties when the user wants to refer to the package later, so
1195 -- we check that the package id can be parsed properly here.
1196 checkPackageId :: InstalledPackageInfo -> Validate ()
1197 checkPackageId ipi =
1198 let str = display (sourcePackageId ipi) in
1199 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1201 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1202 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1204 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1205 checkDuplicates db_stack pkg update = do
1207 pkgid = sourcePackageId pkg
1208 pkgs = packages (head db_stack)
1210 -- Check whether this package id already exists in this DB
1212 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1213 verror CannotForce $
1214 "package " ++ display pkgid ++ " is already installed"
1217 uncasep = map toLower . display
1218 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1220 when (not update && not (null dups)) $ verror ForceAll $
1221 "Package names may be treated case-insensitively in the future.\n"++
1222 "Package " ++ display pkgid ++
1223 " overlaps with: " ++ unwords (map display dups)
1226 checkDir :: String -> String -> Validate ()
1227 checkDir thisfield d
1228 | "$topdir" `isPrefixOf` d = return ()
1229 | "$httptopdir" `isPrefixOf` d = return ()
1230 -- can't check these, because we don't know what $(http)topdir is
1232 there <- liftIO $ doesDirectoryExist d
1234 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1236 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1237 checkDep db_stack pkgid
1238 | pkgid `elem` pkgids = return ()
1239 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1240 ++ "\" doesn't exist")
1242 all_pkgs = allPackagesInStack db_stack
1243 pkgids = map installedPackageId all_pkgs
1245 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1246 checkDuplicateDepends deps
1247 | null dups = return ()
1248 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1249 unwords (map display dups))
1251 dups = [ p | (p:_:_) <- group (sort deps) ]
1253 checkHSLib :: [String] -> Bool -> String -> Validate ()
1254 checkHSLib dirs auto_ghci_libs lib = do
1255 let batch_lib_file = "lib" ++ lib ++ ".a"
1256 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1258 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1260 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1262 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1263 doesFileExistOnPath file path = go path
1264 where go [] = return Nothing
1265 go (p:ps) = do b <- doesFileExistIn file p
1266 if b then return (Just p) else go ps
1268 doesFileExistIn :: String -> String -> IO Bool
1269 doesFileExistIn lib d
1270 | "$topdir" `isPrefixOf` d = return True
1271 | "$httptopdir" `isPrefixOf` d = return True
1272 | otherwise = doesFileExist (d </> lib)
1274 checkModules :: InstalledPackageInfo -> Validate ()
1275 checkModules pkg = do
1276 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1278 findModule modl = do
1279 -- there's no .hi file for GHC.Prim
1280 if modl == fromString "GHC.Prim" then return () else do
1281 let file = toFilePath modl <.> "hi"
1282 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1283 when (isNothing m) $
1284 verror ForceFiles ("file " ++ file ++ " is missing")
1286 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1287 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1288 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1290 m <- doesFileExistOnPath ghci_lib_file dirs
1291 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1292 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1294 ghci_lib_file = lib <.> "o"
1296 -- automatically build the GHCi version of a batch lib,
1297 -- using ld --whole-archive.
1299 autoBuildGHCiLib :: String -> String -> String -> IO ()
1300 autoBuildGHCiLib dir batch_file ghci_file = do
1301 let ghci_lib_file = dir ++ '/':ghci_file
1302 batch_lib_file = dir ++ '/':batch_file
1303 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1304 #if defined(darwin_HOST_OS)
1305 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1306 #elif defined(mingw32_HOST_OS)
1307 execDir <- getLibDir
1308 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1310 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1312 when (r /= ExitSuccess) $ exitWith r
1313 hPutStrLn stderr (" done.")
1315 -- -----------------------------------------------------------------------------
1316 -- Searching for modules
1320 findModules :: [FilePath] -> IO [String]
1322 mms <- mapM searchDir paths
1325 searchDir path prefix = do
1326 fs <- getDirectoryEntries path `catch` \_ -> return []
1327 searchEntries path prefix fs
1329 searchEntries path prefix [] = return []
1330 searchEntries path prefix (f:fs)
1331 | looks_like_a_module = do
1332 ms <- searchEntries path prefix fs
1333 return (prefix `joinModule` f : ms)
1334 | looks_like_a_component = do
1335 ms <- searchDir (path </> f) (prefix `joinModule` f)
1336 ms' <- searchEntries path prefix fs
1339 searchEntries path prefix fs
1342 (base,suffix) = splitFileExt f
1343 looks_like_a_module =
1344 suffix `elem` haskell_suffixes &&
1345 all okInModuleName base
1346 looks_like_a_component =
1347 null suffix && all okInModuleName base
1353 -- ---------------------------------------------------------------------------
1354 -- expanding environment variables in the package configuration
1356 expandEnvVars :: String -> Force -> IO String
1357 expandEnvVars str0 force = go str0 ""
1359 go "" acc = return $! reverse acc
1360 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1361 = do value <- lookupEnvVar var
1362 go rest (reverse value ++ acc)
1363 where close c = c == '}' || c == '\n' -- don't span newlines
1367 lookupEnvVar :: String -> IO String
1369 catch (System.Environment.getEnv nm)
1370 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1374 -----------------------------------------------------------------------------
1376 getProgramName :: IO String
1377 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1378 where str `withoutSuffix` suff
1379 | suff `isSuffixOf` str = take (length str - length suff) str
1382 bye :: String -> IO a
1383 bye s = putStr s >> exitWith ExitSuccess
1385 die :: String -> IO a
1388 dieWith :: Int -> String -> IO a
1391 prog <- getProgramName
1392 hPutStrLn stderr (prog ++ ": " ++ s)
1393 exitWith (ExitFailure ec)
1395 dieOrForceAll :: Force -> String -> IO ()
1396 dieOrForceAll ForceAll s = ignoreError s
1397 dieOrForceAll _other s = dieForcible s
1399 ignoreError :: String -> IO ()
1400 ignoreError s = reportError (s ++ " (ignoring)")
1402 reportError :: String -> IO ()
1403 reportError s = do hFlush stdout; hPutStrLn stderr s
1405 dieForcible :: String -> IO ()
1406 dieForcible s = die (s ++ " (use --force to override)")
1408 my_head :: String -> [a] -> a
1409 my_head s [] = error s
1410 my_head _ (x : _) = x
1412 -----------------------------------------
1413 -- Cut and pasted from ghc/compiler/main/SysTools
1415 #if defined(mingw32_HOST_OS)
1416 subst :: Char -> Char -> String -> String
1417 subst a b ls = map (\ x -> if x == a then b else x) ls
1419 unDosifyPath :: FilePath -> FilePath
1420 unDosifyPath xs = subst '\\' '/' xs
1422 getLibDir :: IO (Maybe String)
1423 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1425 -- (getExecDir cmd) returns the directory in which the current
1426 -- executable, which should be called 'cmd', is running
1427 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1428 -- you'll get "/a/b/c" back as the result
1429 getExecDir :: String -> IO (Maybe String)
1431 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1432 where initN n = reverse . drop n . reverse
1433 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1435 getExecPath :: IO (Maybe String)
1437 allocaArray len $ \buf -> do
1438 ret <- getModuleFileName nullPtr buf len
1439 if ret == 0 then return Nothing
1440 else liftM Just $ peekCString buf
1441 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1443 foreign import stdcall unsafe "GetModuleFileNameA"
1444 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1447 getLibDir :: IO (Maybe String)
1448 getLibDir = return Nothing
1451 -----------------------------------------
1452 -- Adapted from ghc/compiler/utils/Panic
1454 installSignalHandlers :: IO ()
1455 installSignalHandlers = do
1456 threadid <- myThreadId
1458 interrupt = Exception.throwTo threadid
1459 (Exception.ErrorCall "interrupted")
1461 #if !defined(mingw32_HOST_OS)
1462 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1463 _ <- installHandler sigINT (Catch interrupt) Nothing
1465 #elif __GLASGOW_HASKELL__ >= 603
1466 -- GHC 6.3+ has support for console events on Windows
1467 -- NOTE: running GHCi under a bash shell for some reason requires
1468 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1469 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1470 -- why --SDM 17/12/2004
1471 let sig_handler ControlC = interrupt
1472 sig_handler Break = interrupt
1473 sig_handler _ = return ()
1475 _ <- installHandler (Catch sig_handler)
1478 return () -- nothing
1481 #if __GLASGOW_HASKELL__ <= 604
1482 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1483 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1486 #if mingw32_HOST_OS || mingw32_TARGET_OS
1487 throwIOIO :: Exception.IOException -> IO a
1488 throwIOIO = Exception.throwIO
1490 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1491 catchIO = Exception.catch
1494 catchError :: IO a -> (String -> IO a) -> IO a
1495 catchError io handler = io `Exception.catch` handler'
1496 where handler' (Exception.ErrorCall err) = handler err
1499 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1500 -- to use text files here, rather than binary files.
1501 writeFileAtomic :: FilePath -> String -> IO ()
1502 writeFileAtomic targetFile content = do
1503 (newFile, newHandle) <- openNewFile targetDir template
1504 do hPutStr newHandle content
1506 #if mingw32_HOST_OS || mingw32_TARGET_OS
1507 renameFile newFile targetFile
1508 -- If the targetFile exists then renameFile will fail
1509 `catchIO` \err -> do
1510 exists <- doesFileExist targetFile
1512 then do removeFile targetFile
1513 -- Big fat hairy race condition
1514 renameFile newFile targetFile
1515 -- If the removeFile succeeds and the renameFile fails
1516 -- then we've lost the atomic property.
1519 renameFile newFile targetFile
1521 `Exception.onException` do hClose newHandle
1524 template = targetName <.> "tmp"
1525 targetDir | null targetDir_ = "."
1526 | otherwise = targetDir_
1527 --TODO: remove this when takeDirectory/splitFileName is fixed
1528 -- to always return a valid dir
1529 (targetDir_,targetName) = splitFileName targetFile
1531 -- Ugh, this is a copy/paste of code from the base library, but
1532 -- if uses 666 rather than 600 for the permissions.
1533 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1534 openNewFile dir template = do
1538 -- We split off the last extension, so we can use .foo.ext files
1539 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1540 -- below filepath in the hierarchy here.
1542 case break (== '.') $ reverse template of
1543 -- First case: template contains no '.'s. Just re-reverse it.
1544 (rev_suffix, "") -> (reverse rev_suffix, "")
1545 -- Second case: template contains at least one '.'. Strip the
1546 -- dot from the prefix and prepend it to the suffix (if we don't
1547 -- do this, the unique number will get added after the '.' and
1548 -- thus be part of the extension, which is wrong.)
1549 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1550 -- Otherwise, something is wrong, because (break (== '.')) should
1551 -- always return a pair with either the empty string or a string
1552 -- beginning with '.' as the second component.
1553 _ -> error "bug in System.IO.openTempFile"
1555 oflags = rw_flags .|. o_EXCL
1557 #if __GLASGOW_HASKELL__ < 611
1558 withFilePath = withCString
1562 fd <- withFilePath filepath $ \ f ->
1563 c_open f oflags 0o666
1568 then findTempName (x+1)
1569 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1571 -- XXX We want to tell fdToHandle what the filepath is,
1572 -- as any exceptions etc will only be able to report the
1575 #if __GLASGOW_HASKELL__ >= 609
1578 fdToHandle (fromIntegral fd)
1580 `Exception.onException` c_close fd
1581 return (filepath, h)
1583 filename = prefix ++ show x ++ suffix
1584 filepath = dir `combine` filename
1586 -- XXX Copied from GHC.Handle
1587 std_flags, output_flags, rw_flags :: CInt
1588 std_flags = o_NONBLOCK .|. o_NOCTTY
1589 output_flags = std_flags .|. o_CREAT
1590 rw_flags = output_flags .|. o_RDWR
1592 -- | The function splits the given string to substrings
1593 -- using 'isSearchPathSeparator'.
1594 parseSearchPath :: String -> [FilePath]
1595 parseSearchPath path = split path
1597 split :: String -> [String]
1601 _:rest -> chunk : split rest
1605 #ifdef mingw32_HOST_OS
1606 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1610 (chunk', rest') = break isSearchPathSeparator s