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
51 import qualified Data.ByteString.Lazy as B
52 import qualified Data.Binary as Bin
53 import qualified Data.Binary.Get as Bin
57 #ifdef mingw32_HOST_OS
58 import GHC.ConsoleHandler
60 import System.Posix hiding (fdToHandle)
63 import IO ( isPermissionError )
64 import System.Posix.Internals
65 #if __GLASGOW_HASKELL__ >= 611
66 import GHC.IO.Handle.FD (fdToHandle)
68 import GHC.Handle (fdToHandle)
72 import System.Process(runInteractiveCommand)
73 import qualified System.Info(os)
76 #if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
77 import System.Console.Terminfo as Terminfo
80 -- -----------------------------------------------------------------------------
87 case getOpt Permute (flags ++ deprecFlags) args of
88 (cli,_,[]) | FlagHelp `elem` cli -> do
89 prog <- getProgramName
90 bye (usageInfo (usageHeader prog) flags)
91 (cli,_,[]) | FlagVersion `elem` cli ->
94 case getVerbosity Normal cli of
95 Right v -> runit v cli nonopts
98 prog <- getProgramName
99 die (concat errors ++ usageInfo (usageHeader prog) flags)
101 -- -----------------------------------------------------------------------------
102 -- Command-line syntax
109 | FlagConfig FilePath
110 | FlagGlobalConfig FilePath
118 | FlagVerbosity (Maybe String)
121 flags :: [OptDescr Flag]
123 Option [] ["user"] (NoArg FlagUser)
124 "use the current user's package database",
125 Option [] ["global"] (NoArg FlagGlobal)
126 "use the global package database",
127 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
128 "use the specified package config file",
129 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
130 "location of the global package config",
131 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
132 "never read the user package database",
133 Option [] ["force"] (NoArg FlagForce)
134 "ignore missing dependencies, directories, and libraries",
135 Option [] ["force-files"] (NoArg FlagForceFiles)
136 "ignore missing directories and libraries only",
137 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
138 "automatically build libs for GHCi (with register)",
139 Option ['?'] ["help"] (NoArg FlagHelp)
140 "display this help and exit",
141 Option ['V'] ["version"] (NoArg FlagVersion)
142 "output version information and exit",
143 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
144 "print output in easy-to-parse format for some commands",
145 Option [] ["names-only"] (NoArg FlagNamesOnly)
146 "only print package names, not versions; can only be used with list --simple-output",
147 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
148 "ignore case for substring matching",
149 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
150 "verbosity level (0-2, default 1)"
153 data Verbosity = Silent | Normal | Verbose
154 deriving (Show, Eq, Ord)
156 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
157 getVerbosity v [] = Right v
158 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
159 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
160 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
161 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
162 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
163 getVerbosity v (_ : fs) = getVerbosity v fs
165 deprecFlags :: [OptDescr Flag]
167 -- put deprecated flags here
170 ourCopyright :: String
171 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
173 usageHeader :: String -> String
174 usageHeader prog = substProg prog $
176 " $p init {path}\n" ++
177 " Create and initialise a package database at the location {path}.\n" ++
178 " Packages can be registered in the new database using the register\n" ++
179 " command with --package-conf={path}. To use the new database with GHC,\n" ++
180 " use GHC's -package-conf flag.\n" ++
182 " $p register {filename | -}\n" ++
183 " Register the package using the specified installed package\n" ++
184 " description. The syntax for the latter is given in the $p\n" ++
185 " documentation.\n" ++
187 " $p update {filename | -}\n" ++
188 " Register the package, overwriting any other package with the\n" ++
191 " $p unregister {pkg-id}\n" ++
192 " Unregister the specified package.\n" ++
194 " $p expose {pkg-id}\n" ++
195 " Expose the specified package.\n" ++
197 " $p hide {pkg-id}\n" ++
198 " Hide the specified package.\n" ++
200 " $p list [pkg]\n" ++
201 " List registered packages in the global database, and also the\n" ++
202 " user database if --user is given. If a package name is given\n" ++
203 " all the registered versions will be listed in ascending order.\n" ++
204 " Accepts the --simple-output flag.\n" ++
207 " Generate a graph of the package dependencies in a form suitable\n" ++
208 " for input for the graphviz tools. For example, to generate a PDF" ++
209 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
211 " $p find-module {module}\n" ++
212 " List registered packages exposing module {module} in the global\n" ++
213 " database, and also the user database if --user is given.\n" ++
214 " All the registered versions will be listed in ascending order.\n" ++
215 " Accepts the --simple-output flag.\n" ++
217 " $p latest {pkg-id}\n" ++
218 " Prints the highest registered version of a package.\n" ++
221 " Check the consistency of package depenencies and list broken packages.\n" ++
222 " Accepts the --simple-output flag.\n" ++
224 " $p describe {pkg}\n" ++
225 " Give the registered description for the specified package. The\n" ++
226 " description is returned in precisely the syntax required by $p\n" ++
229 " $p field {pkg} {field}\n" ++
230 " Extract the specified field of the package description for the\n" ++
231 " specified package. Accepts comma-separated multiple fields.\n" ++
234 " Dump the registered description for every package. This is like\n" ++
235 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
236 " by tools that parse the results, rather than humans.\n" ++
238 " Substring matching is supported for {module} in find-module and\n" ++
239 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
240 " open substring ends (prefix*, *suffix, *infix*).\n" ++
242 " When asked to modify a database (register, unregister, update,\n"++
243 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
244 " default. Specifying --user causes it to act on the user database,\n"++
245 " or --package-conf can be used to act on another database\n"++
246 " entirely. When multiple of these options are given, the rightmost\n"++
247 " one is used as the database to act upon.\n"++
249 " Commands that query the package database (list, tree, latest, describe,\n"++
250 " field) operate on the list of databases specified by the flags\n"++
251 " --user, --global, and --package-conf. If none of these flags are\n"++
252 " given, the default is --global --user.\n"++
254 " The following optional flags are also accepted:\n"
256 substProg :: String -> String -> String
258 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
259 substProg prog (c:xs) = c : substProg prog xs
261 -- -----------------------------------------------------------------------------
264 data Force = NoForce | ForceFiles | ForceAll | CannotForce
267 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
269 runit :: Verbosity -> [Flag] -> [String] -> IO ()
270 runit verbosity cli nonopts = do
271 installSignalHandlers -- catch ^C and clean up
272 prog <- getProgramName
275 | FlagForce `elem` cli = ForceAll
276 | FlagForceFiles `elem` cli = ForceFiles
277 | otherwise = NoForce
278 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
279 splitFields fields = unfoldr splitComma (',':fields)
280 where splitComma "" = Nothing
281 splitComma fs = Just $ break (==',') (tail fs)
283 substringCheck :: String -> Maybe (String -> Bool)
284 substringCheck "" = Nothing
285 substringCheck "*" = Just (const True)
286 substringCheck [_] = Nothing
287 substringCheck (h:t) =
288 case (h, init t, last t) of
289 ('*',s,'*') -> Just (isInfixOf (f s) . f)
290 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
291 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
293 where f | FlagIgnoreCase `elem` cli = map toLower
296 glob x | System.Info.os=="mingw32" = do
297 -- glob echoes its argument, after win32 filename globbing
298 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
299 txt <- hGetContents o
301 glob x | otherwise = return [x]
304 -- first, parse the command
307 -- dummy command to demonstrate usage and permit testing
308 -- without messing things up; use glob to selectively enable
309 -- windows filename globbing for file parameters
310 -- register, update, FlagGlobalConfig, FlagConfig; others?
311 ["glob", filename] -> do
313 glob filename >>= print
315 ["init", filename] ->
316 initPackageDB filename verbosity cli
317 ["register", filename] ->
318 registerPackage filename verbosity cli auto_ghci_libs False force
319 ["update", filename] ->
320 registerPackage filename verbosity cli auto_ghci_libs True force
321 ["unregister", pkgid_str] -> do
322 pkgid <- readGlobPkgId pkgid_str
323 unregisterPackage pkgid verbosity cli force
324 ["expose", pkgid_str] -> do
325 pkgid <- readGlobPkgId pkgid_str
326 exposePackage pkgid verbosity cli force
327 ["hide", pkgid_str] -> do
328 pkgid <- readGlobPkgId pkgid_str
329 hidePackage pkgid verbosity cli force
331 listPackages verbosity cli Nothing Nothing
332 ["list", pkgid_str] ->
333 case substringCheck pkgid_str of
334 Nothing -> do pkgid <- readGlobPkgId pkgid_str
335 listPackages verbosity cli (Just (Id pkgid)) Nothing
336 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
338 showPackageDot verbosity cli
339 ["find-module", moduleName] -> do
340 let match = maybe (==moduleName) id (substringCheck moduleName)
341 listPackages verbosity cli Nothing (Just match)
342 ["latest", pkgid_str] -> do
343 pkgid <- readGlobPkgId pkgid_str
344 latestPackage verbosity cli pkgid
345 ["describe", pkgid_str] ->
346 case substringCheck pkgid_str of
347 Nothing -> do pkgid <- readGlobPkgId pkgid_str
348 describePackage verbosity cli (Id pkgid)
349 Just m -> describePackage verbosity cli (Substring pkgid_str m)
350 ["field", pkgid_str, fields] ->
351 case substringCheck pkgid_str of
352 Nothing -> do pkgid <- readGlobPkgId pkgid_str
353 describeField verbosity cli (Id pkgid)
355 Just m -> describeField verbosity cli (Substring pkgid_str m)
358 checkConsistency verbosity cli
361 dumpPackages verbosity cli
364 recache verbosity cli
367 die ("missing command\n" ++
368 usageInfo (usageHeader prog) flags)
370 die ("command-line syntax error\n" ++
371 usageInfo (usageHeader prog) flags)
373 parseCheck :: ReadP a a -> String -> String -> IO a
374 parseCheck parser str what =
375 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
377 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
379 readGlobPkgId :: String -> IO PackageIdentifier
380 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
382 parseGlobPackageId :: ReadP r PackageIdentifier
388 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
390 -- globVersion means "all versions"
391 globVersion :: Version
392 globVersion = Version{ versionBranch=[], versionTags=["*"] }
394 -- -----------------------------------------------------------------------------
397 -- Some commands operate on a single database:
398 -- register, unregister, expose, hide
399 -- however these commands also check the union of the available databases
400 -- in order to check consistency. For example, register will check that
401 -- dependencies exist before registering a package.
403 -- Some commands operate on multiple databases, with overlapping semantics:
404 -- list, describe, field
407 = PackageDB { location :: FilePath,
408 packages :: [InstalledPackageInfo] }
410 type PackageDBStack = [PackageDB]
411 -- A stack of package databases. Convention: head is the topmost
414 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
415 allPackagesInStack = concatMap packages
417 getPkgDatabases :: Verbosity
418 -> Bool -- we are modifying, not reading
419 -> Bool -- read caches, if available
421 -> IO (PackageDBStack,
422 -- the real package DB stack: [global,user] ++
423 -- DBs specified on the command line with -f.
425 -- which one to modify, if any
427 -- the package DBs specified on the command
428 -- line, or [global,user] otherwise. This
429 -- is used as the list of package DBs for
430 -- commands that just read the DB, such as 'list'.
432 getPkgDatabases verbosity modify use_cache my_flags = do
433 -- first we determine the location of the global package config. On Windows,
434 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
435 -- location is passed to the binary using the --global-config flag by the
437 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
439 case [ f | FlagGlobalConfig f <- my_flags ] of
440 [] -> do mb_dir <- getLibDir
442 Nothing -> die err_msg
444 r <- lookForPackageDBIn dir
446 Nothing -> die ("Can't find package database in " ++ dir)
447 Just path -> return path
448 fs -> return (last fs)
450 let no_user_db = FlagNoUserDb `elem` my_flags
452 -- get the location of the user package database, and create it if necessary
453 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
454 e_appdir <- try $ getAppUserDataDirectory "ghc"
457 if no_user_db then return Nothing else
459 Left _ -> return Nothing
461 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
462 dir = appdir </> subdir
463 r <- lookForPackageDBIn dir
465 Nothing -> return (Just (dir </> "package.conf.d", False))
466 Just f -> return (Just (f, True))
468 -- If the user database doesn't exist, and this command isn't a
469 -- "modify" command, then we won't attempt to create or use it.
471 | Just (user_conf,user_exists) <- mb_user_conf,
472 modify || user_exists = [user_conf, global_conf]
473 | otherwise = [global_conf]
475 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
478 Left _ -> sys_databases
480 | last cs == "" -> init cs ++ sys_databases
482 where cs = parseSearchPath path
484 -- The "global" database is always the one at the bottom of the stack.
485 -- This is the database we modify by default.
486 virt_global_conf = last env_stack
488 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
489 where is_db_flag FlagUser
490 | Just (user_conf, _user_exists) <- mb_user_conf
492 is_db_flag FlagGlobal = Just virt_global_conf
493 is_db_flag (FlagConfig f) = Just f
494 is_db_flag _ = Nothing
496 let flag_db_names | null db_flags = env_stack
497 | otherwise = reverse (nub db_flags)
499 -- For a "modify" command, treat all the databases as
500 -- a stack, where we are modifying the top one, but it
501 -- can refer to packages in databases further down the
504 -- -f flags on the command line add to the database
505 -- stack, unless any of them are present in the stack
507 let final_stack = filter (`notElem` env_stack)
508 [ f | FlagConfig f <- reverse my_flags ]
511 -- the database we actually modify is the one mentioned
512 -- rightmost on the command-line.
514 | not modify = Nothing
515 | null db_flags = Just virt_global_conf
516 | otherwise = Just (last db_flags)
518 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
520 let flag_db_stack = [ db | db_name <- flag_db_names,
521 db <- db_stack, location db == db_name ]
523 return (db_stack, to_modify, flag_db_stack)
526 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
527 lookForPackageDBIn dir = do
528 let path_dir = dir </> "package.conf.d"
529 exists_dir <- doesDirectoryExist path_dir
530 if exists_dir then return (Just path_dir) else do
531 let path_file = dir </> "package.conf"
532 exists_file <- doesFileExist path_file
533 if exists_file then return (Just path_file) else return Nothing
535 readParseDatabase :: Verbosity
536 -> Maybe (FilePath,Bool)
541 readParseDatabase verbosity mb_user_conf use_cache path
542 -- the user database (only) is allowed to be non-existent
543 | Just (user_conf,False) <- mb_user_conf, path == user_conf
544 = return PackageDB { location = path, packages = [] }
546 = do e <- try $ getDirectoryContents path
549 pkgs <- parseMultiPackageConf verbosity path
550 return PackageDB{ location = path, packages = pkgs }
552 | not use_cache -> ignore_cache
554 let cache = path </> cachefilename
555 tdir <- getModificationTime path
556 e_tcache <- try $ getModificationTime cache
559 when (verbosity > Normal) $
560 putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
563 | tcache >= tdir -> do
564 when (verbosity > Normal) $
565 putStrLn ("using cache: " ++ cache)
566 pkgs <- myReadBinPackageDB cache
567 let pkgs' = map convertPackageInfoIn pkgs
568 return PackageDB { location = path, packages = pkgs' }
570 when (verbosity >= Normal) $ do
571 putStrLn ("WARNING: cache is out of date: " ++ cache)
572 putStrLn " use 'ghc-pkg recache' to fix."
576 let confs = filter (".conf" `isSuffixOf`) fs
577 pkgs <- mapM (parseSingletonPackageConf verbosity) $
579 return PackageDB { location = path, packages = pkgs }
581 -- read the package.cache file strictly, to work around a problem with
582 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
583 -- after it has been completely read, leading to a sharing violation
585 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
586 myReadBinPackageDB filepath = do
587 h <- openBinaryFile filepath ReadMode
589 b <- B.hGet h (fromIntegral sz)
591 return $ Bin.runGet Bin.get b
593 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
594 parseMultiPackageConf verbosity file = do
595 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
597 let pkgs = map convertPackageInfoIn $ read str
598 Exception.evaluate pkgs
600 die ("error while parsing " ++ file ++ ": " ++ show e)
602 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
603 parseSingletonPackageConf verbosity file = do
604 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
605 readFile file >>= parsePackageInfo
607 cachefilename :: FilePath
608 cachefilename = "package.cache"
610 -- -----------------------------------------------------------------------------
611 -- Creating a new package DB
613 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
614 initPackageDB filename verbosity _flags = do
615 let eexist = die ("cannot create: " ++ filename ++ " already exists")
616 b1 <- doesFileExist filename
618 b2 <- doesDirectoryExist filename
620 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
622 -- -----------------------------------------------------------------------------
625 registerPackage :: FilePath
628 -> Bool -- auto_ghci_libs
632 registerPackage input verbosity my_flags auto_ghci_libs update force = do
633 (db_stack, Just to_modify, _flag_dbs) <-
634 getPkgDatabases verbosity True True my_flags
637 db_to_operate_on = my_head "register" $
638 filter ((== to_modify).location) db_stack
643 when (verbosity >= Normal) $
644 putStr "Reading package info from stdin ... "
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 writeFileAtomic 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 writeBinPackageDB 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 putStrLn ("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) || __GLASGOW_HASKELL__ < 611 || 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 ()
937 doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
939 -- PackageId is can have globVersion for the version
940 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
941 findPackages db_stack pkgarg
942 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
944 findPackagesByDB :: PackageDBStack -> PackageArg
945 -> IO [(PackageDB, [InstalledPackageInfo])]
946 findPackagesByDB db_stack pkgarg
947 = case [ (db, matched)
949 let matched = filter (pkgarg `matchesPkg`) (packages db),
950 not (null matched) ] of
951 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
954 pkg_msg (Id pkgid) = display pkgid
955 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
957 matches :: PackageIdentifier -> PackageIdentifier -> Bool
959 = (pkgName pid == pkgName pid')
960 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
962 realVersion :: PackageIdentifier -> Bool
963 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
964 -- when versionBranch == [], this is a glob
966 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
967 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
968 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
970 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
971 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
973 -- -----------------------------------------------------------------------------
976 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
977 describeField verbosity my_flags pkgarg fields = do
978 (_, _, flag_db_stack) <-
979 getPkgDatabases verbosity False True{-use cache-} my_flags
980 fns <- toFields fields
981 ps <- findPackages flag_db_stack pkgarg
982 let top_dir = takeDirectory (location (last flag_db_stack))
983 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
984 where toFields [] = return []
985 toFields (f:fs) = case toField f of
986 Nothing -> die ("unknown field: " ++ f)
987 Just fn -> do fns <- toFields fs
989 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
991 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
992 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
993 -- with the current topdir (obtained from the -B option).
994 mungePackagePaths top_dir ps = map munge_pkg ps
996 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
997 includeDirs = munge_paths (includeDirs p),
998 libraryDirs = munge_paths (libraryDirs p),
999 frameworkDirs = munge_paths (frameworkDirs p),
1000 haddockInterfaces = munge_paths (haddockInterfaces p),
1001 haddockHTMLs = munge_paths (haddockHTMLs p)
1004 munge_paths = map munge_path
1007 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1008 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1011 toHttpPath p = "file:///" ++ p
1013 maybePrefixMatch :: String -> String -> Maybe String
1014 maybePrefixMatch [] rest = Just rest
1015 maybePrefixMatch (_:_) [] = Nothing
1016 maybePrefixMatch (p:pat) (r:rest)
1017 | p == r = maybePrefixMatch pat rest
1018 | otherwise = Nothing
1020 toField :: String -> Maybe (InstalledPackageInfo -> String)
1021 -- backwards compatibility:
1022 toField "import_dirs" = Just $ strList . importDirs
1023 toField "source_dirs" = Just $ strList . importDirs
1024 toField "library_dirs" = Just $ strList . libraryDirs
1025 toField "hs_libraries" = Just $ strList . hsLibraries
1026 toField "extra_libraries" = Just $ strList . extraLibraries
1027 toField "include_dirs" = Just $ strList . includeDirs
1028 toField "c_includes" = Just $ strList . includes
1029 toField "package_deps" = Just $ strList . map display. depends
1030 toField "extra_cc_opts" = Just $ strList . ccOptions
1031 toField "extra_ld_opts" = Just $ strList . ldOptions
1032 toField "framework_dirs" = Just $ strList . frameworkDirs
1033 toField "extra_frameworks"= Just $ strList . frameworks
1034 toField s = showInstalledPackageInfoField s
1036 strList :: [String] -> String
1040 -- -----------------------------------------------------------------------------
1041 -- Check: Check consistency of installed packages
1043 checkConsistency :: Verbosity -> [Flag] -> IO ()
1044 checkConsistency verbosity my_flags = do
1045 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1046 -- check behaves like modify for the purposes of deciding which
1047 -- databases to use, because ordering is important.
1049 let simple_output = FlagSimpleOutput `elem` my_flags
1051 let pkgs = allPackagesInStack db_stack
1054 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
1058 when (not simple_output) $ do
1059 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1060 _ <- reportValidateErrors es " " Nothing
1064 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1066 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1067 where not_in p = sourcePackageId p `notElem` all_ps
1068 all_ps = map sourcePackageId pkgs1
1070 let not_broken_pkgs = filterOut broken_pkgs pkgs
1071 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1072 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1074 when (not (null all_broken_pkgs)) $ do
1076 then simplePackageList my_flags all_broken_pkgs
1078 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1079 "listed above, or because they depend on a broken package.")
1080 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1082 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1085 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1086 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1087 closure pkgs db_stack = go pkgs db_stack
1089 go avail not_avail =
1090 case partition (depsAvailable avail) not_avail of
1091 ([], not_avail') -> (avail, not_avail')
1092 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1094 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1096 depsAvailable pkgs_ok pkg = null dangling
1097 where dangling = filter (`notElem` pids) (depends pkg)
1098 pids = map installedPackageId pkgs_ok
1100 -- we want mutually recursive groups of package to show up
1101 -- as broken. (#1750)
1103 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1104 brokenPackages pkgs = snd (closure [] pkgs)
1106 -- -----------------------------------------------------------------------------
1107 -- Manipulating package.conf files
1109 type InstalledPackageInfoString = InstalledPackageInfo_ String
1111 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1112 convertPackageInfoOut
1113 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1114 hiddenModules = h })) =
1115 pkgconf{ exposedModules = map display e,
1116 hiddenModules = map display h }
1118 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1119 convertPackageInfoIn
1120 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1121 hiddenModules = h })) =
1122 pkgconf{ exposedModules = map convert e,
1123 hiddenModules = map convert h }
1124 where convert = fromJust . simpleParse
1126 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1127 writeNewConfig verbosity filename ipis = do
1128 when (verbosity >= Normal) $
1129 hPutStr stdout "Writing new package config file... "
1130 createDirectoryIfMissing True $ takeDirectory filename
1131 let shown = concat $ intersperse ",\n "
1132 $ map (show . convertPackageInfoOut) ipis
1133 fileContents = "[" ++ shown ++ "\n]"
1134 writeFileAtomic filename fileContents
1136 if isPermissionError e
1137 then die (filename ++ ": you don't have permission to modify this file")
1139 when (verbosity >= Normal) $
1140 hPutStrLn stdout "done."
1142 -----------------------------------------------------------------------------
1143 -- Sanity-check a new package config, and automatically build GHCi libs
1146 type ValidateError = (Force,String)
1148 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
1150 instance Monad Validate where
1151 return a = V $ return (a, [])
1153 (a, es) <- runValidate m
1154 (b, es') <- runValidate (k a)
1157 verror :: Force -> String -> Validate ()
1158 verror f s = V (return ((),[(f,s)]))
1160 liftIO :: IO a -> Validate a
1161 liftIO k = V (k >>= \a -> return (a,[]))
1163 -- returns False if we should die
1164 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
1165 reportValidateErrors es prefix mb_force = do
1166 oks <- mapM report es
1170 | Just force <- mb_force
1172 then do reportError (prefix ++ s ++ " (ignoring)")
1174 else if f < CannotForce
1175 then do reportError (prefix ++ s ++ " (use --force to override)")
1177 else do reportError err
1179 | otherwise = do reportError err
1184 validatePackageConfig :: InstalledPackageInfo
1186 -> Bool -- auto-ghc-libs
1187 -> Bool -- update, or check
1190 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1191 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1192 ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
1193 when (not ok) $ exitWith (ExitFailure 1)
1195 checkPackageConfig :: InstalledPackageInfo
1197 -> Bool -- auto-ghc-libs
1198 -> Bool -- update, or check
1200 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1201 checkInstalledPackageId pkg db_stack update
1203 checkDuplicates db_stack pkg update
1204 mapM_ (checkDep db_stack) (depends pkg)
1205 checkDuplicateDepends (depends pkg)
1206 mapM_ (checkDir "import-dirs") (importDirs pkg)
1207 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
1208 mapM_ (checkDir "include-dirs") (includeDirs pkg)
1210 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1211 -- ToDo: check these somehow?
1212 -- extra_libraries :: [String],
1213 -- c_includes :: [String],
1215 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1217 checkInstalledPackageId ipi db_stack update = do
1218 let ipid@(InstalledPackageId str) = installedPackageId ipi
1219 when (null str) $ verror CannotForce "missing id field"
1220 let dups = [ p | p <- allPackagesInStack db_stack,
1221 installedPackageId p == ipid ]
1222 when (not update && not (null dups)) $
1223 verror CannotForce $
1224 "package(s) with this id already exist: " ++
1225 unwords (map (display.packageId) dups)
1227 -- When the package name and version are put together, sometimes we can
1228 -- end up with a package id that cannot be parsed. This will lead to
1229 -- difficulties when the user wants to refer to the package later, so
1230 -- we check that the package id can be parsed properly here.
1231 checkPackageId :: InstalledPackageInfo -> Validate ()
1232 checkPackageId ipi =
1233 let str = display (sourcePackageId ipi) in
1234 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1236 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1237 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1239 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1240 checkDuplicates db_stack pkg update = do
1242 pkgid = sourcePackageId pkg
1243 pkgs = packages (head db_stack)
1245 -- Check whether this package id already exists in this DB
1247 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1248 verror CannotForce $
1249 "package " ++ display pkgid ++ " is already installed"
1252 uncasep = map toLower . display
1253 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1255 when (not update && not (null dups)) $ verror ForceAll $
1256 "Package names may be treated case-insensitively in the future.\n"++
1257 "Package " ++ display pkgid ++
1258 " overlaps with: " ++ unwords (map display dups)
1261 checkDir :: String -> String -> Validate ()
1262 checkDir thisfield d
1263 | "$topdir" `isPrefixOf` d = return ()
1264 | "$httptopdir" `isPrefixOf` d = return ()
1265 -- can't check these, because we don't know what $(http)topdir is
1267 there <- liftIO $ doesDirectoryExist d
1269 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1271 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1272 checkDep db_stack pkgid
1273 | pkgid `elem` pkgids = return ()
1274 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1275 ++ "\" doesn't exist")
1277 all_pkgs = allPackagesInStack db_stack
1278 pkgids = map installedPackageId all_pkgs
1280 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1281 checkDuplicateDepends deps
1282 | null dups = return ()
1283 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1284 unwords (map display dups))
1286 dups = [ p | (p:_:_) <- group (sort deps) ]
1288 checkHSLib :: [String] -> Bool -> String -> Validate ()
1289 checkHSLib dirs auto_ghci_libs lib = do
1290 let batch_lib_file = "lib" ++ lib ++ ".a"
1291 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1293 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1295 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1297 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1298 doesFileExistOnPath file path = go path
1299 where go [] = return Nothing
1300 go (p:ps) = do b <- doesFileExistIn file p
1301 if b then return (Just p) else go ps
1303 doesFileExistIn :: String -> String -> IO Bool
1304 doesFileExistIn lib d
1305 | "$topdir" `isPrefixOf` d = return True
1306 | "$httptopdir" `isPrefixOf` d = return True
1307 | otherwise = doesFileExist (d </> lib)
1309 checkModules :: InstalledPackageInfo -> Validate ()
1310 checkModules pkg = do
1311 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1313 findModule modl = do
1314 -- there's no .hi file for GHC.Prim
1315 if modl == fromString "GHC.Prim" then return () else do
1316 let file = toFilePath modl <.> "hi"
1317 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1318 when (isNothing m) $
1319 verror ForceFiles ("file " ++ file ++ " is missing")
1321 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1322 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1323 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1325 m <- doesFileExistOnPath ghci_lib_file dirs
1326 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1327 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1329 ghci_lib_file = lib <.> "o"
1331 -- automatically build the GHCi version of a batch lib,
1332 -- using ld --whole-archive.
1334 autoBuildGHCiLib :: String -> String -> String -> IO ()
1335 autoBuildGHCiLib dir batch_file ghci_file = do
1336 let ghci_lib_file = dir ++ '/':ghci_file
1337 batch_lib_file = dir ++ '/':batch_file
1338 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1339 #if defined(darwin_HOST_OS)
1340 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1341 #elif defined(mingw32_HOST_OS)
1342 execDir <- getLibDir
1343 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1345 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1347 when (r /= ExitSuccess) $ exitWith r
1348 hPutStrLn stderr (" done.")
1350 -- -----------------------------------------------------------------------------
1351 -- Searching for modules
1355 findModules :: [FilePath] -> IO [String]
1357 mms <- mapM searchDir paths
1360 searchDir path prefix = do
1361 fs <- getDirectoryEntries path `catch` \_ -> return []
1362 searchEntries path prefix fs
1364 searchEntries path prefix [] = return []
1365 searchEntries path prefix (f:fs)
1366 | looks_like_a_module = do
1367 ms <- searchEntries path prefix fs
1368 return (prefix `joinModule` f : ms)
1369 | looks_like_a_component = do
1370 ms <- searchDir (path </> f) (prefix `joinModule` f)
1371 ms' <- searchEntries path prefix fs
1374 searchEntries path prefix fs
1377 (base,suffix) = splitFileExt f
1378 looks_like_a_module =
1379 suffix `elem` haskell_suffixes &&
1380 all okInModuleName base
1381 looks_like_a_component =
1382 null suffix && all okInModuleName base
1388 -- ---------------------------------------------------------------------------
1389 -- expanding environment variables in the package configuration
1391 expandEnvVars :: String -> Force -> IO String
1392 expandEnvVars str0 force = go str0 ""
1394 go "" acc = return $! reverse acc
1395 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1396 = do value <- lookupEnvVar var
1397 go rest (reverse value ++ acc)
1398 where close c = c == '}' || c == '\n' -- don't span newlines
1402 lookupEnvVar :: String -> IO String
1404 catch (System.Environment.getEnv nm)
1405 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1409 -----------------------------------------------------------------------------
1411 getProgramName :: IO String
1412 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1413 where str `withoutSuffix` suff
1414 | suff `isSuffixOf` str = take (length str - length suff) str
1417 bye :: String -> IO a
1418 bye s = putStr s >> exitWith ExitSuccess
1420 die :: String -> IO a
1423 dieWith :: Int -> String -> IO a
1426 prog <- getProgramName
1427 hPutStrLn stderr (prog ++ ": " ++ s)
1428 exitWith (ExitFailure ec)
1430 dieOrForceAll :: Force -> String -> IO ()
1431 dieOrForceAll ForceAll s = ignoreError s
1432 dieOrForceAll _other s = dieForcible s
1434 ignoreError :: String -> IO ()
1435 ignoreError s = reportError (s ++ " (ignoring)")
1437 reportError :: String -> IO ()
1438 reportError s = do hFlush stdout; hPutStrLn stderr s
1440 dieForcible :: String -> IO ()
1441 dieForcible s = die (s ++ " (use --force to override)")
1443 my_head :: String -> [a] -> a
1444 my_head s [] = error s
1445 my_head _ (x : _) = x
1447 -----------------------------------------
1448 -- Cut and pasted from ghc/compiler/main/SysTools
1450 #if defined(mingw32_HOST_OS)
1451 subst :: Char -> Char -> String -> String
1452 subst a b ls = map (\ x -> if x == a then b else x) ls
1454 unDosifyPath :: FilePath -> FilePath
1455 unDosifyPath xs = subst '\\' '/' xs
1457 getLibDir :: IO (Maybe String)
1458 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1460 -- (getExecDir cmd) returns the directory in which the current
1461 -- executable, which should be called 'cmd', is running
1462 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1463 -- you'll get "/a/b/c" back as the result
1464 getExecDir :: String -> IO (Maybe String)
1466 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1467 where initN n = reverse . drop n . reverse
1468 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1470 getExecPath :: IO (Maybe String)
1472 allocaArray len $ \buf -> do
1473 ret <- getModuleFileName nullPtr buf len
1474 if ret == 0 then return Nothing
1475 else liftM Just $ peekCString buf
1476 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1478 foreign import stdcall unsafe "GetModuleFileNameA"
1479 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1482 getLibDir :: IO (Maybe String)
1483 getLibDir = return Nothing
1486 -----------------------------------------
1487 -- Adapted from ghc/compiler/utils/Panic
1489 installSignalHandlers :: IO ()
1490 installSignalHandlers = do
1491 threadid <- myThreadId
1493 interrupt = Exception.throwTo threadid
1494 (Exception.ErrorCall "interrupted")
1496 #if !defined(mingw32_HOST_OS)
1497 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1498 _ <- installHandler sigINT (Catch interrupt) Nothing
1500 #elif __GLASGOW_HASKELL__ >= 603
1501 -- GHC 6.3+ has support for console events on Windows
1502 -- NOTE: running GHCi under a bash shell for some reason requires
1503 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1504 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1505 -- why --SDM 17/12/2004
1506 let sig_handler ControlC = interrupt
1507 sig_handler Break = interrupt
1508 sig_handler _ = return ()
1510 _ <- installHandler (Catch sig_handler)
1513 return () -- nothing
1516 #if __GLASGOW_HASKELL__ <= 604
1517 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1518 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1521 #if mingw32_HOST_OS || mingw32_TARGET_OS
1522 throwIOIO :: Exception.IOException -> IO a
1523 throwIOIO = Exception.throwIO
1525 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1526 catchIO = Exception.catch
1529 catchError :: IO a -> (String -> IO a) -> IO a
1530 catchError io handler = io `Exception.catch` handler'
1531 where handler' (Exception.ErrorCall err) = handler err
1534 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1535 -- to use text files here, rather than binary files.
1536 writeFileAtomic :: FilePath -> String -> IO ()
1537 writeFileAtomic targetFile content = do
1538 (newFile, newHandle) <- openNewFile targetDir template
1539 do hPutStr newHandle content
1541 #if mingw32_HOST_OS || mingw32_TARGET_OS
1542 renameFile newFile targetFile
1543 -- If the targetFile exists then renameFile will fail
1544 `catchIO` \err -> do
1545 exists <- doesFileExist targetFile
1547 then do removeFile targetFile
1548 -- Big fat hairy race condition
1549 renameFile newFile targetFile
1550 -- If the removeFile succeeds and the renameFile fails
1551 -- then we've lost the atomic property.
1554 renameFile newFile targetFile
1556 `Exception.onException` do hClose newHandle
1559 template = targetName <.> "tmp"
1560 targetDir | null targetDir_ = "."
1561 | otherwise = targetDir_
1562 --TODO: remove this when takeDirectory/splitFileName is fixed
1563 -- to always return a valid dir
1564 (targetDir_,targetName) = splitFileName targetFile
1566 -- Ugh, this is a copy/paste of code from the base library, but
1567 -- if uses 666 rather than 600 for the permissions.
1568 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1569 openNewFile dir template = do
1573 -- We split off the last extension, so we can use .foo.ext files
1574 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1575 -- below filepath in the hierarchy here.
1577 case break (== '.') $ reverse template of
1578 -- First case: template contains no '.'s. Just re-reverse it.
1579 (rev_suffix, "") -> (reverse rev_suffix, "")
1580 -- Second case: template contains at least one '.'. Strip the
1581 -- dot from the prefix and prepend it to the suffix (if we don't
1582 -- do this, the unique number will get added after the '.' and
1583 -- thus be part of the extension, which is wrong.)
1584 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1585 -- Otherwise, something is wrong, because (break (== '.')) should
1586 -- always return a pair with either the empty string or a string
1587 -- beginning with '.' as the second component.
1588 _ -> error "bug in System.IO.openTempFile"
1590 oflags = rw_flags .|. o_EXCL
1592 #if __GLASGOW_HASKELL__ < 611
1593 withFilePath = withCString
1597 fd <- withFilePath filepath $ \ f ->
1598 c_open f oflags 0o666
1603 then findTempName (x+1)
1604 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1606 -- XXX We want to tell fdToHandle what the filepath is,
1607 -- as any exceptions etc will only be able to report the
1610 #if __GLASGOW_HASKELL__ >= 609
1613 fdToHandle (fromIntegral fd)
1615 `Exception.onException` c_close fd
1616 return (filepath, h)
1618 filename = prefix ++ show x ++ suffix
1619 filepath = dir `combine` filename
1621 -- XXX Copied from GHC.Handle
1622 std_flags, output_flags, rw_flags :: CInt
1623 std_flags = o_NONBLOCK .|. o_NOCTTY
1624 output_flags = std_flags .|. o_CREAT
1625 rw_flags = output_flags .|. o_RDWR
1627 -- | The function splits the given string to substrings
1628 -- using 'isSearchPathSeparator'.
1629 parseSearchPath :: String -> [FilePath]
1630 parseSearchPath path = split path
1632 split :: String -> [String]
1636 _:rest -> chunk : split rest
1640 #ifdef mingw32_HOST_OS
1641 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1645 (chunk', rest') = break isSearchPathSeparator s