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 __GLASGOW_HASKELL__ >= 611
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 register {filename | -}\n" ++
177 " Register the package using the specified installed package\n" ++
178 " description. The syntax for the latter is given in the $p\n" ++
179 " documentation.\n" ++
181 " $p update {filename | -}\n" ++
182 " Register the package, overwriting any other package with the\n" ++
185 " $p unregister {pkg-id}\n" ++
186 " Unregister the specified package.\n" ++
188 " $p expose {pkg-id}\n" ++
189 " Expose the specified package.\n" ++
191 " $p hide {pkg-id}\n" ++
192 " Hide the specified package.\n" ++
194 " $p list [pkg]\n" ++
195 " List registered packages in the global database, and also the\n" ++
196 " user database if --user is given. If a package name is given\n" ++
197 " all the registered versions will be listed in ascending order.\n" ++
198 " Accepts the --simple-output flag.\n" ++
201 " Generate a graph of the package dependencies in a form suitable\n" ++
202 " for input for the graphviz tools. For example, to generate a PDF" ++
203 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
205 " $p find-module {module}\n" ++
206 " List registered packages exposing module {module} in the global\n" ++
207 " database, and also the user database if --user is given.\n" ++
208 " All the registered versions will be listed in ascending order.\n" ++
209 " Accepts the --simple-output flag.\n" ++
211 " $p latest {pkg-id}\n" ++
212 " Prints the highest registered version of a package.\n" ++
215 " Check the consistency of package depenencies and list broken packages.\n" ++
216 " Accepts the --simple-output flag.\n" ++
218 " $p describe {pkg}\n" ++
219 " Give the registered description for the specified package. The\n" ++
220 " description is returned in precisely the syntax required by $p\n" ++
223 " $p field {pkg} {field}\n" ++
224 " Extract the specified field of the package description for the\n" ++
225 " specified package. Accepts comma-separated multiple fields.\n" ++
228 " Dump the registered description for every package. This is like\n" ++
229 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
230 " by tools that parse the results, rather than humans.\n" ++
232 " Substring matching is supported for {module} in find-module and\n" ++
233 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
234 " open substring ends (prefix*, *suffix, *infix*).\n" ++
236 " When asked to modify a database (register, unregister, update,\n"++
237 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
238 " default. Specifying --user causes it to act on the user database,\n"++
239 " or --package-conf can be used to act on another database\n"++
240 " entirely. When multiple of these options are given, the rightmost\n"++
241 " one is used as the database to act upon.\n"++
243 " Commands that query the package database (list, tree, latest, describe,\n"++
244 " field) operate on the list of databases specified by the flags\n"++
245 " --user, --global, and --package-conf. If none of these flags are\n"++
246 " given, the default is --global --user.\n"++
248 " The following optional flags are also accepted:\n"
250 substProg :: String -> String -> String
252 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
253 substProg prog (c:xs) = c : substProg prog xs
255 -- -----------------------------------------------------------------------------
258 data Force = NoForce | ForceFiles | ForceAll | CannotForce
261 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
263 runit :: Verbosity -> [Flag] -> [String] -> IO ()
264 runit verbosity cli nonopts = do
265 installSignalHandlers -- catch ^C and clean up
266 prog <- getProgramName
269 | FlagForce `elem` cli = ForceAll
270 | FlagForceFiles `elem` cli = ForceFiles
271 | otherwise = NoForce
272 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
273 splitFields fields = unfoldr splitComma (',':fields)
274 where splitComma "" = Nothing
275 splitComma fs = Just $ break (==',') (tail fs)
277 substringCheck :: String -> Maybe (String -> Bool)
278 substringCheck "" = Nothing
279 substringCheck "*" = Just (const True)
280 substringCheck [_] = Nothing
281 substringCheck (h:t) =
282 case (h, init t, last t) of
283 ('*',s,'*') -> Just (isInfixOf (f s) . f)
284 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
285 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
287 where f | FlagIgnoreCase `elem` cli = map toLower
290 glob x | System.Info.os=="mingw32" = do
291 -- glob echoes its argument, after win32 filename globbing
292 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
293 txt <- hGetContents o
295 glob x | otherwise = return [x]
298 -- first, parse the command
301 -- dummy command to demonstrate usage and permit testing
302 -- without messing things up; use glob to selectively enable
303 -- windows filename globbing for file parameters
304 -- register, update, FlagGlobalConfig, FlagConfig; others?
305 ["glob", filename] -> do
307 glob filename >>= print
309 ["register", filename] ->
310 registerPackage filename verbosity cli auto_ghci_libs False force
311 ["update", filename] ->
312 registerPackage filename verbosity cli auto_ghci_libs True force
313 ["unregister", pkgid_str] -> do
314 pkgid <- readGlobPkgId pkgid_str
315 unregisterPackage pkgid verbosity cli force
316 ["expose", pkgid_str] -> do
317 pkgid <- readGlobPkgId pkgid_str
318 exposePackage pkgid verbosity cli force
319 ["hide", pkgid_str] -> do
320 pkgid <- readGlobPkgId pkgid_str
321 hidePackage pkgid verbosity cli force
323 listPackages verbosity cli Nothing Nothing
324 ["list", pkgid_str] ->
325 case substringCheck pkgid_str of
326 Nothing -> do pkgid <- readGlobPkgId pkgid_str
327 listPackages verbosity cli (Just (Id pkgid)) Nothing
328 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
330 showPackageDot verbosity cli
331 ["find-module", moduleName] -> do
332 let match = maybe (==moduleName) id (substringCheck moduleName)
333 listPackages verbosity cli Nothing (Just match)
334 ["latest", pkgid_str] -> do
335 pkgid <- readGlobPkgId pkgid_str
336 latestPackage verbosity cli pkgid
337 ["describe", pkgid_str] ->
338 case substringCheck pkgid_str of
339 Nothing -> do pkgid <- readGlobPkgId pkgid_str
340 describePackage verbosity cli (Id pkgid)
341 Just m -> describePackage verbosity cli (Substring pkgid_str m)
342 ["field", pkgid_str, fields] ->
343 case substringCheck pkgid_str of
344 Nothing -> do pkgid <- readGlobPkgId pkgid_str
345 describeField verbosity cli (Id pkgid)
347 Just m -> describeField verbosity cli (Substring pkgid_str m)
350 checkConsistency verbosity cli
353 dumpPackages verbosity cli
356 recache verbosity cli
359 die ("missing command\n" ++
360 usageInfo (usageHeader prog) flags)
362 die ("command-line syntax error\n" ++
363 usageInfo (usageHeader prog) flags)
365 parseCheck :: ReadP a a -> String -> String -> IO a
366 parseCheck parser str what =
367 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
369 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
371 readGlobPkgId :: String -> IO PackageIdentifier
372 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
374 parseGlobPackageId :: ReadP r PackageIdentifier
380 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
382 -- globVersion means "all versions"
383 globVersion :: Version
384 globVersion = Version{ versionBranch=[], versionTags=["*"] }
386 -- -----------------------------------------------------------------------------
389 -- Some commands operate on a single database:
390 -- register, unregister, expose, hide
391 -- however these commands also check the union of the available databases
392 -- in order to check consistency. For example, register will check that
393 -- dependencies exist before registering a package.
395 -- Some commands operate on multiple databases, with overlapping semantics:
396 -- list, describe, field
399 = PackageDB { location :: FilePath,
400 packages :: [InstalledPackageInfo] }
402 type PackageDBStack = [PackageDB]
403 -- A stack of package databases. Convention: head is the topmost
406 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
407 allPackagesInStack = concatMap packages
409 getPkgDatabases :: Verbosity
410 -> Bool -- we are modifying, not reading
411 -> Bool -- read caches, if available
413 -> IO (PackageDBStack,
414 -- the real package DB stack: [global,user] ++
415 -- DBs specified on the command line with -f.
417 -- which one to modify, if any
419 -- the package DBs specified on the command
420 -- line, or [global,user] otherwise. This
421 -- is used as the list of package DBs for
422 -- commands that just read the DB, such as 'list'.
424 getPkgDatabases verbosity modify use_cache my_flags = do
425 -- first we determine the location of the global package config. On Windows,
426 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
427 -- location is passed to the binary using the --global-config flag by the
429 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
431 case [ f | FlagGlobalConfig f <- my_flags ] of
432 [] -> do mb_dir <- getLibDir
434 Nothing -> die err_msg
436 r <- lookForPackageDBIn dir
438 Nothing -> die ("Can't find package database in " ++ dir)
439 Just path -> return path
440 fs -> return (last fs)
442 let no_user_db = FlagNoUserDb `elem` my_flags
444 -- get the location of the user package database, and create it if necessary
445 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
446 e_appdir <- try $ getAppUserDataDirectory "ghc"
449 if no_user_db then return Nothing else
451 Left _ -> return Nothing
453 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
454 dir = appdir </> subdir
455 r <- lookForPackageDBIn dir
457 Nothing -> return (Just (dir </> "package.conf.d", False))
458 Just f -> return (Just (f, True))
460 -- If the user database doesn't exist, and this command isn't a
461 -- "modify" command, then we won't attempt to create or use it.
463 | Just (user_conf,user_exists) <- mb_user_conf,
464 modify || user_exists = [user_conf, global_conf]
465 | otherwise = [global_conf]
467 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
470 Left _ -> sys_databases
472 | last cs == "" -> init cs ++ sys_databases
474 where cs = parseSearchPath path
476 -- The "global" database is always the one at the bottom of the stack.
477 -- This is the database we modify by default.
478 virt_global_conf = last env_stack
480 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
481 where is_db_flag FlagUser
482 | Just (user_conf, _user_exists) <- mb_user_conf
484 is_db_flag FlagGlobal = Just virt_global_conf
485 is_db_flag (FlagConfig f) = Just f
486 is_db_flag _ = Nothing
488 let flag_db_names | null db_flags = env_stack
489 | otherwise = reverse (nub db_flags)
491 -- For a "modify" command, treat all the databases as
492 -- a stack, where we are modifying the top one, but it
493 -- can refer to packages in databases further down the
496 -- -f flags on the command line add to the database
497 -- stack, unless any of them are present in the stack
499 let final_stack = filter (`notElem` env_stack)
500 [ f | FlagConfig f <- reverse my_flags ]
503 -- the database we actually modify is the one mentioned
504 -- rightmost on the command-line.
506 | not modify = Nothing
507 | null db_flags = Just virt_global_conf
508 | otherwise = Just (last db_flags)
510 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
512 let flag_db_stack = [ db | db_name <- flag_db_names,
513 db <- db_stack, location db == db_name ]
515 return (db_stack, to_modify, flag_db_stack)
518 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
519 lookForPackageDBIn dir = do
520 let path_dir = dir </> "package.conf.d"
521 exists_dir <- doesDirectoryExist path_dir
522 if exists_dir then return (Just path_dir) else do
523 let path_file = dir </> "package.conf"
524 exists_file <- doesFileExist path_file
525 if exists_file then return (Just path_file) else return Nothing
527 readParseDatabase :: Verbosity
528 -> Maybe (FilePath,Bool)
533 readParseDatabase verbosity mb_user_conf use_cache path
534 -- the user database (only) is allowed to be non-existent
535 | Just (user_conf,False) <- mb_user_conf, path == user_conf
536 = return PackageDB { location = path, packages = [] }
538 = do e <- try $ getDirectoryContents path
541 pkgs <- parseMultiPackageConf verbosity path
542 return PackageDB{ location = path, packages = pkgs }
544 | not use_cache -> ignore_cache
546 let cache = path </> cachefilename
547 tdir <- getModificationTime path
548 e_tcache <- try $ getModificationTime cache
551 when (verbosity > Normal) $
552 putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
555 | tcache >= tdir -> do
556 when (verbosity > Normal) $
557 putStrLn ("using cache: " ++ cache)
558 pkgs <- myReadBinPackageDB cache
559 let pkgs' = map convertPackageInfoIn pkgs
560 return PackageDB { location = path, packages = pkgs' }
562 when (verbosity >= Normal) $ do
563 putStrLn ("WARNING: cache is out of date: " ++ cache)
564 putStrLn " use 'ghc-pkg recache' to fix."
568 let confs = filter (".conf" `isSuffixOf`) fs
569 pkgs <- mapM (parseSingletonPackageConf verbosity) $
571 return PackageDB { location = path, packages = pkgs }
573 -- read the package.cache file strictly, to work around a problem with
574 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
575 -- after it has been completely read, leading to a sharing violation
577 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
578 myReadBinPackageDB filepath = do
579 h <- openBinaryFile filepath ReadMode
581 b <- B.hGet h (fromIntegral sz)
583 return $ Bin.runGet Bin.get b
585 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
586 parseMultiPackageConf verbosity file = do
587 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
589 let pkgs = map convertPackageInfoIn $ read str
590 Exception.evaluate pkgs
592 die ("error while parsing " ++ file ++ ": " ++ show e)
594 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
595 parseSingletonPackageConf verbosity file = do
596 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
597 readFile file >>= parsePackageInfo
599 cachefilename :: FilePath
600 cachefilename = "package.cache"
602 -- -----------------------------------------------------------------------------
605 registerPackage :: FilePath
608 -> Bool -- auto_ghci_libs
612 registerPackage input verbosity my_flags auto_ghci_libs update force = do
613 (db_stack, Just to_modify, _flag_dbs) <-
614 getPkgDatabases verbosity True True my_flags
617 db_to_operate_on = my_head "register" $
618 filter ((== to_modify).location) db_stack
623 when (verbosity >= Normal) $
624 putStr "Reading package info from stdin ... "
627 when (verbosity >= Normal) $
628 putStr ("Reading package info from " ++ show f ++ " ... ")
631 expanded <- expandEnvVars s force
633 pkg <- parsePackageInfo expanded
634 when (verbosity >= Normal) $
637 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
638 -- truncate the stack for validation, because we don't allow
639 -- packages lower in the stack to refer to those higher up.
640 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
642 removes = [ RemovePackage p
643 | p <- packages db_to_operate_on,
644 sourcePackageId p == sourcePackageId pkg ]
646 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
650 -> IO InstalledPackageInfo
651 parsePackageInfo str =
652 case parseInstalledPackageInfo str of
653 ParseOk _warns ok -> return ok
654 ParseFailed err -> case locatedErrorMsg err of
655 (Nothing, s) -> die s
656 (Just l, s) -> die (show l ++ ": " ++ s)
658 -- -----------------------------------------------------------------------------
659 -- Making changes to a package database
661 data DBOp = RemovePackage InstalledPackageInfo
662 | AddPackage InstalledPackageInfo
663 | ModifyPackage InstalledPackageInfo
665 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
666 changeDB verbosity cmds db = do
667 let db' = updateInternalDB db cmds
668 isfile <- doesFileExist (location db)
670 then writeNewConfig verbosity (location db') (packages db')
672 createDirectoryIfMissing True (location db)
673 changeDBDir verbosity cmds db'
675 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
676 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
678 do_cmd pkgs (RemovePackage p) =
679 filter ((/= installedPackageId p) . installedPackageId) pkgs
680 do_cmd pkgs (AddPackage p) = p : pkgs
681 do_cmd pkgs (ModifyPackage p) =
682 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
685 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
686 changeDBDir verbosity cmds db = do
688 updateDBCache verbosity db
690 do_cmd (RemovePackage p) = do
691 let file = location db </> display (installedPackageId p) <.> "conf"
692 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
694 do_cmd (AddPackage p) = do
695 let file = location db </> display (installedPackageId p) <.> "conf"
696 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
697 writeFileAtomic file (showInstalledPackageInfo p)
698 do_cmd (ModifyPackage p) =
699 do_cmd (AddPackage p)
701 updateDBCache :: Verbosity -> PackageDB -> IO ()
702 updateDBCache verbosity db = do
703 let filename = location db </> cachefilename
704 when (verbosity > Normal) $
705 putStrLn ("writing cache " ++ filename)
706 writeBinPackageDB filename (map convertPackageInfoOut (packages db))
708 if isPermissionError e
709 then die (filename ++ ": you don't have permission to modify this file")
712 -- -----------------------------------------------------------------------------
713 -- Exposing, Hiding, Unregistering are all similar
715 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
716 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
718 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
719 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
721 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
722 unregisterPackage = modifyPackage RemovePackage
725 :: (InstalledPackageInfo -> DBOp)
731 modifyPackage fn pkgid verbosity my_flags force = do
732 (db_stack, Just _to_modify, _flag_dbs) <-
733 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
735 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
737 db_name = location db
740 pids = map sourcePackageId ps
742 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
743 new_db = updateInternalDB db cmds
745 old_broken = brokenPackages (allPackagesInStack db_stack)
746 rest_of_stack = filter ((/= db_name) . location) db_stack
747 new_stack = new_db : rest_of_stack
748 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
749 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
751 when (not (null newly_broken)) $
752 dieOrForceAll force ("unregistering " ++ display pkgid ++
753 " would break the following packages: "
754 ++ unwords (map display newly_broken))
756 changeDB verbosity cmds db
758 recache :: Verbosity -> [Flag] -> IO ()
759 recache verbosity my_flags = do
760 (db_stack, Just to_modify, _flag_dbs) <-
761 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
763 db_to_operate_on = my_head "recache" $
764 filter ((== to_modify).location) db_stack
766 changeDB verbosity [] db_to_operate_on
768 -- -----------------------------------------------------------------------------
771 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
772 -> Maybe (String->Bool)
774 listPackages verbosity my_flags mPackageName mModuleName = do
775 let simple_output = FlagSimpleOutput `elem` my_flags
776 (db_stack, _, flag_db_stack) <-
777 getPkgDatabases verbosity False True{-use cache-} my_flags
779 let db_stack_filtered -- if a package is given, filter out all other packages
780 | Just this <- mPackageName =
781 [ db{ packages = filter (this `matchesPkg`) (packages db) }
782 | db <- flag_db_stack ]
783 | Just match <- mModuleName = -- packages which expose mModuleName
784 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
785 | db <- flag_db_stack ]
786 | otherwise = flag_db_stack
789 = [ db{ packages = sort_pkgs (packages db) }
790 | db <- db_stack_filtered ]
791 where sort_pkgs = sortBy cmpPkgIds
792 cmpPkgIds pkg1 pkg2 =
793 case pkgName p1 `compare` pkgName p2 of
796 EQ -> pkgVersion p1 `compare` pkgVersion p2
797 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
799 stack = reverse db_stack_sorted
801 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
803 pkg_map = allPackagesInStack db_stack
804 broken = map sourcePackageId (brokenPackages pkg_map)
806 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
807 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
809 pp_pkgs = map pp_pkg pkg_confs
811 | sourcePackageId p `elem` broken = printf "{%s}" doc
813 | otherwise = printf "(%s)" doc
814 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
817 InstalledPackageId ipid = installedPackageId p
818 pkg = display (sourcePackageId p)
820 show_simple = simplePackageList my_flags . allPackagesInStack
822 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
823 prog <- getProgramName
824 putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
826 if simple_output then show_simple stack else do
828 #if __GLASGOW_HASKELL__ < 611
829 mapM_ show_normal stack
832 show_colour withF db =
833 mconcat $ map (<#> termText "\n") $
834 (termText (location db) :
835 map (termText " " <#>) (map pp_pkg (packages db)))
838 | sourcePackageId p `elem` broken = withF Red doc
840 | otherwise = withF Blue doc
841 where doc | verbosity >= Verbose
842 = termText (printf "%s (%s)" pkg ipid)
846 InstalledPackageId ipid = installedPackageId p
847 pkg = display (sourcePackageId p)
849 is_tty <- hIsTerminalDevice stdout
851 then mapM_ show_normal stack
852 else do tty <- Terminfo.setupTermFromEnv
853 case Terminfo.getCapability tty withForegroundColor of
854 Nothing -> mapM_ show_normal stack
855 Just w -> runTermOutput tty $ mconcat $
856 map (show_colour w) stack
859 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
860 simplePackageList my_flags pkgs = do
861 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
863 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
864 when (not (null pkgs)) $
865 hPutStrLn stdout $ concat $ intersperse " " strs
867 showPackageDot :: Verbosity -> [Flag] -> IO ()
868 showPackageDot verbosity myflags = do
869 (_, _, flag_db_stack) <-
870 getPkgDatabases verbosity False True{-use cache-} myflags
872 let all_pkgs = allPackagesInStack flag_db_stack
873 ipix = PackageIndex.listToInstalledPackageIndex all_pkgs
876 let quote s = '"':s ++ "\""
877 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
879 let from = display (sourcePackageId p),
881 Just dep <- [PackageIndex.lookupInstalledPackage ipix depid],
882 let to = display (sourcePackageId dep)
886 -- -----------------------------------------------------------------------------
887 -- Prints the highest (hidden or exposed) version of a package
889 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
890 latestPackage verbosity my_flags pkgid = do
891 (_, _, flag_db_stack) <-
892 getPkgDatabases verbosity False True{-use cache-} my_flags
894 ps <- findPackages flag_db_stack (Id pkgid)
895 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
897 show_pkg [] = die "no matches"
898 show_pkg pids = hPutStrLn stdout (display (last pids))
900 -- -----------------------------------------------------------------------------
903 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
904 describePackage verbosity my_flags pkgarg = do
905 (_, _, flag_db_stack) <-
906 getPkgDatabases verbosity False True{-use cache-} my_flags
907 ps <- findPackages flag_db_stack pkgarg
910 dumpPackages :: Verbosity -> [Flag] -> IO ()
911 dumpPackages verbosity my_flags = do
912 (_, _, flag_db_stack) <-
913 getPkgDatabases verbosity False True{-use cache-} my_flags
914 doDump (allPackagesInStack flag_db_stack)
916 doDump :: [InstalledPackageInfo] -> IO ()
917 doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
919 -- PackageId is can have globVersion for the version
920 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
921 findPackages db_stack pkgarg
922 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
924 findPackagesByDB :: PackageDBStack -> PackageArg
925 -> IO [(PackageDB, [InstalledPackageInfo])]
926 findPackagesByDB db_stack pkgarg
927 = case [ (db, matched)
929 let matched = filter (pkgarg `matchesPkg`) (packages db),
930 not (null matched) ] of
931 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
934 pkg_msg (Id pkgid) = display pkgid
935 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
937 matches :: PackageIdentifier -> PackageIdentifier -> Bool
939 = (pkgName pid == pkgName pid')
940 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
942 realVersion :: PackageIdentifier -> Bool
943 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
944 -- when versionBranch == [], this is a glob
946 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
947 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
948 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
950 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
951 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
953 -- -----------------------------------------------------------------------------
956 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
957 describeField verbosity my_flags pkgarg fields = do
958 (_, _, flag_db_stack) <-
959 getPkgDatabases verbosity False True{-use cache-} my_flags
960 fns <- toFields fields
961 ps <- findPackages flag_db_stack pkgarg
962 let top_dir = takeDirectory (location (last flag_db_stack))
963 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
964 where toFields [] = return []
965 toFields (f:fs) = case toField f of
966 Nothing -> die ("unknown field: " ++ f)
967 Just fn -> do fns <- toFields fs
969 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
971 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
972 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
973 -- with the current topdir (obtained from the -B option).
974 mungePackagePaths top_dir ps = map munge_pkg ps
976 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
977 includeDirs = munge_paths (includeDirs p),
978 libraryDirs = munge_paths (libraryDirs p),
979 frameworkDirs = munge_paths (frameworkDirs p),
980 haddockInterfaces = munge_paths (haddockInterfaces p),
981 haddockHTMLs = munge_paths (haddockHTMLs p)
984 munge_paths = map munge_path
987 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
988 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
991 toHttpPath p = "file:///" ++ p
993 maybePrefixMatch :: String -> String -> Maybe String
994 maybePrefixMatch [] rest = Just rest
995 maybePrefixMatch (_:_) [] = Nothing
996 maybePrefixMatch (p:pat) (r:rest)
997 | p == r = maybePrefixMatch pat rest
998 | otherwise = Nothing
1000 toField :: String -> Maybe (InstalledPackageInfo -> String)
1001 -- backwards compatibility:
1002 toField "import_dirs" = Just $ strList . importDirs
1003 toField "source_dirs" = Just $ strList . importDirs
1004 toField "library_dirs" = Just $ strList . libraryDirs
1005 toField "hs_libraries" = Just $ strList . hsLibraries
1006 toField "extra_libraries" = Just $ strList . extraLibraries
1007 toField "include_dirs" = Just $ strList . includeDirs
1008 toField "c_includes" = Just $ strList . includes
1009 toField "package_deps" = Just $ strList . map display. depends
1010 toField "extra_cc_opts" = Just $ strList . ccOptions
1011 toField "extra_ld_opts" = Just $ strList . ldOptions
1012 toField "framework_dirs" = Just $ strList . frameworkDirs
1013 toField "extra_frameworks"= Just $ strList . frameworks
1014 toField s = showInstalledPackageInfoField s
1016 strList :: [String] -> String
1020 -- -----------------------------------------------------------------------------
1021 -- Check: Check consistency of installed packages
1023 checkConsistency :: Verbosity -> [Flag] -> IO ()
1024 checkConsistency verbosity my_flags = do
1025 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1026 -- check behaves like modify for the purposes of deciding which
1027 -- databases to use, because ordering is important.
1029 let simple_output = FlagSimpleOutput `elem` my_flags
1031 let pkgs = allPackagesInStack db_stack
1034 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
1038 when (not simple_output) $ do
1039 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1040 _ <- reportValidateErrors es " " Nothing
1044 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1046 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1047 where not_in p = sourcePackageId p `notElem` all_ps
1048 all_ps = map sourcePackageId pkgs1
1050 let not_broken_pkgs = filterOut broken_pkgs pkgs
1051 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1052 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1054 when (not (null all_broken_pkgs)) $ do
1056 then simplePackageList my_flags all_broken_pkgs
1058 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1059 "listed above, or because they depend on a broken package.")
1060 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1062 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1065 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1066 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1067 closure pkgs db_stack = go pkgs db_stack
1069 go avail not_avail =
1070 case partition (depsAvailable avail) not_avail of
1071 ([], not_avail') -> (avail, not_avail')
1072 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1074 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1076 depsAvailable pkgs_ok pkg = null dangling
1077 where dangling = filter (`notElem` pids) (depends pkg)
1078 pids = map installedPackageId pkgs_ok
1080 -- we want mutually recursive groups of package to show up
1081 -- as broken. (#1750)
1083 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1084 brokenPackages pkgs = snd (closure [] pkgs)
1086 -- -----------------------------------------------------------------------------
1087 -- Manipulating package.conf files
1089 type InstalledPackageInfoString = InstalledPackageInfo_ String
1091 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1092 convertPackageInfoOut
1093 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1094 hiddenModules = h })) =
1095 pkgconf{ exposedModules = map display e,
1096 hiddenModules = map display h }
1098 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1099 convertPackageInfoIn
1100 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1101 hiddenModules = h })) =
1102 pkgconf{ exposedModules = map convert e,
1103 hiddenModules = map convert h }
1104 where convert = fromJust . simpleParse
1106 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1107 writeNewConfig verbosity filename ipis = do
1108 when (verbosity >= Normal) $
1109 hPutStr stdout "Writing new package config file... "
1110 createDirectoryIfMissing True $ takeDirectory filename
1111 let shown = concat $ intersperse ",\n "
1112 $ map (show . convertPackageInfoOut) ipis
1113 fileContents = "[" ++ shown ++ "\n]"
1114 writeFileAtomic filename fileContents
1116 if isPermissionError e
1117 then die (filename ++ ": you don't have permission to modify this file")
1119 when (verbosity >= Normal) $
1120 hPutStrLn stdout "done."
1122 -----------------------------------------------------------------------------
1123 -- Sanity-check a new package config, and automatically build GHCi libs
1126 type ValidateError = (Force,String)
1128 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
1130 instance Monad Validate where
1131 return a = V $ return (a, [])
1133 (a, es) <- runValidate m
1134 (b, es') <- runValidate (k a)
1137 verror :: Force -> String -> Validate ()
1138 verror f s = V (return ((),[(f,s)]))
1140 liftIO :: IO a -> Validate a
1141 liftIO k = V (k >>= \a -> return (a,[]))
1143 -- returns False if we should die
1144 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
1145 reportValidateErrors es prefix mb_force = do
1146 oks <- mapM report es
1150 | Just force <- mb_force
1152 then do reportError (prefix ++ s ++ " (ignoring)")
1154 else if f < CannotForce
1155 then do reportError (prefix ++ s ++ " (use --force to override)")
1157 else do reportError err
1159 | otherwise = do reportError err
1164 validatePackageConfig :: InstalledPackageInfo
1166 -> Bool -- auto-ghc-libs
1167 -> Bool -- update, or check
1170 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1171 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1172 ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
1173 when (not ok) $ exitWith (ExitFailure 1)
1175 checkPackageConfig :: InstalledPackageInfo
1177 -> Bool -- auto-ghc-libs
1178 -> Bool -- update, or check
1180 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1181 checkInstalledPackageId pkg db_stack update
1183 checkDuplicates db_stack pkg update
1184 mapM_ (checkDep db_stack) (depends pkg)
1185 checkDuplicateDepends (depends pkg)
1186 mapM_ (checkDir "import-dirs") (importDirs pkg)
1187 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
1188 mapM_ (checkDir "include-dirs") (includeDirs pkg)
1190 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1191 -- ToDo: check these somehow?
1192 -- extra_libraries :: [String],
1193 -- c_includes :: [String],
1195 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1197 checkInstalledPackageId ipi db_stack update = do
1198 let ipid@(InstalledPackageId str) = installedPackageId ipi
1199 when (null str) $ verror CannotForce "missing id field"
1200 let dups = [ p | p <- allPackagesInStack db_stack,
1201 installedPackageId p == ipid ]
1202 when (not update && not (null dups)) $
1203 verror CannotForce $
1204 "package(s) with this id already exist: " ++
1205 unwords (map (display.packageId) dups)
1207 -- When the package name and version are put together, sometimes we can
1208 -- end up with a package id that cannot be parsed. This will lead to
1209 -- difficulties when the user wants to refer to the package later, so
1210 -- we check that the package id can be parsed properly here.
1211 checkPackageId :: InstalledPackageInfo -> Validate ()
1212 checkPackageId ipi =
1213 let str = display (sourcePackageId ipi) in
1214 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1216 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1217 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1219 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1220 checkDuplicates db_stack pkg update = do
1222 pkgid = sourcePackageId pkg
1223 pkgs = packages (head db_stack)
1225 -- Check whether this package id already exists in this DB
1227 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1228 verror CannotForce $
1229 "package " ++ display pkgid ++ " is already installed"
1232 uncasep = map toLower . display
1233 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1235 when (not update && not (null dups)) $ verror ForceAll $
1236 "Package names may be treated case-insensitively in the future.\n"++
1237 "Package " ++ display pkgid ++
1238 " overlaps with: " ++ unwords (map display dups)
1241 checkDir :: String -> String -> Validate ()
1242 checkDir thisfield d
1243 | "$topdir" `isPrefixOf` d = return ()
1244 | "$httptopdir" `isPrefixOf` d = return ()
1245 -- can't check these, because we don't know what $(http)topdir is
1247 there <- liftIO $ doesDirectoryExist d
1249 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1251 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1252 checkDep db_stack pkgid
1253 | pkgid `elem` pkgids = return ()
1254 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1255 ++ "\" doesn't exist")
1257 all_pkgs = allPackagesInStack db_stack
1258 pkgids = map installedPackageId all_pkgs
1260 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1261 checkDuplicateDepends deps
1262 | null dups = return ()
1263 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1264 unwords (map display dups))
1266 dups = [ p | (p:_:_) <- group (sort deps) ]
1268 checkHSLib :: [String] -> Bool -> String -> Validate ()
1269 checkHSLib dirs auto_ghci_libs lib = do
1270 let batch_lib_file = "lib" ++ lib ++ ".a"
1271 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1273 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1275 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1277 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1278 doesFileExistOnPath file path = go path
1279 where go [] = return Nothing
1280 go (p:ps) = do b <- doesFileExistIn file p
1281 if b then return (Just p) else go ps
1283 doesFileExistIn :: String -> String -> IO Bool
1284 doesFileExistIn lib d
1285 | "$topdir" `isPrefixOf` d = return True
1286 | "$httptopdir" `isPrefixOf` d = return True
1287 | otherwise = doesFileExist (d </> lib)
1289 checkModules :: InstalledPackageInfo -> Validate ()
1290 checkModules pkg = do
1291 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1293 findModule modl = do
1294 -- there's no .hi file for GHC.Prim
1295 if modl == fromString "GHC.Prim" then return () else do
1296 let file = toFilePath modl <.> "hi"
1297 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1298 when (isNothing m) $
1299 verror ForceFiles ("file " ++ file ++ " is missing")
1301 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1302 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1303 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1305 m <- doesFileExistOnPath ghci_lib_file dirs
1306 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1307 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1309 ghci_lib_file = lib <.> "o"
1311 -- automatically build the GHCi version of a batch lib,
1312 -- using ld --whole-archive.
1314 autoBuildGHCiLib :: String -> String -> String -> IO ()
1315 autoBuildGHCiLib dir batch_file ghci_file = do
1316 let ghci_lib_file = dir ++ '/':ghci_file
1317 batch_lib_file = dir ++ '/':batch_file
1318 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1319 #if defined(darwin_HOST_OS)
1320 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1321 #elif defined(mingw32_HOST_OS)
1322 execDir <- getLibDir
1323 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1325 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1327 when (r /= ExitSuccess) $ exitWith r
1328 hPutStrLn stderr (" done.")
1330 -- -----------------------------------------------------------------------------
1331 -- Searching for modules
1335 findModules :: [FilePath] -> IO [String]
1337 mms <- mapM searchDir paths
1340 searchDir path prefix = do
1341 fs <- getDirectoryEntries path `catch` \_ -> return []
1342 searchEntries path prefix fs
1344 searchEntries path prefix [] = return []
1345 searchEntries path prefix (f:fs)
1346 | looks_like_a_module = do
1347 ms <- searchEntries path prefix fs
1348 return (prefix `joinModule` f : ms)
1349 | looks_like_a_component = do
1350 ms <- searchDir (path </> f) (prefix `joinModule` f)
1351 ms' <- searchEntries path prefix fs
1354 searchEntries path prefix fs
1357 (base,suffix) = splitFileExt f
1358 looks_like_a_module =
1359 suffix `elem` haskell_suffixes &&
1360 all okInModuleName base
1361 looks_like_a_component =
1362 null suffix && all okInModuleName base
1368 -- ---------------------------------------------------------------------------
1369 -- expanding environment variables in the package configuration
1371 expandEnvVars :: String -> Force -> IO String
1372 expandEnvVars str0 force = go str0 ""
1374 go "" acc = return $! reverse acc
1375 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1376 = do value <- lookupEnvVar var
1377 go rest (reverse value ++ acc)
1378 where close c = c == '}' || c == '\n' -- don't span newlines
1382 lookupEnvVar :: String -> IO String
1384 catch (System.Environment.getEnv nm)
1385 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1389 -----------------------------------------------------------------------------
1391 getProgramName :: IO String
1392 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1393 where str `withoutSuffix` suff
1394 | suff `isSuffixOf` str = take (length str - length suff) str
1397 bye :: String -> IO a
1398 bye s = putStr s >> exitWith ExitSuccess
1400 die :: String -> IO a
1403 dieWith :: Int -> String -> IO a
1406 prog <- getProgramName
1407 hPutStrLn stderr (prog ++ ": " ++ s)
1408 exitWith (ExitFailure ec)
1410 dieOrForceAll :: Force -> String -> IO ()
1411 dieOrForceAll ForceAll s = ignoreError s
1412 dieOrForceAll _other s = dieForcible s
1414 ignoreError :: String -> IO ()
1415 ignoreError s = reportError (s ++ " (ignoring)")
1417 reportError :: String -> IO ()
1418 reportError s = do hFlush stdout; hPutStrLn stderr s
1420 dieForcible :: String -> IO ()
1421 dieForcible s = die (s ++ " (use --force to override)")
1423 my_head :: String -> [a] -> a
1424 my_head s [] = error s
1425 my_head _ (x : _) = x
1427 -----------------------------------------
1428 -- Cut and pasted from ghc/compiler/main/SysTools
1430 #if defined(mingw32_HOST_OS)
1431 subst :: Char -> Char -> String -> String
1432 subst a b ls = map (\ x -> if x == a then b else x) ls
1434 unDosifyPath :: FilePath -> FilePath
1435 unDosifyPath xs = subst '\\' '/' xs
1437 getLibDir :: IO (Maybe String)
1438 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1440 -- (getExecDir cmd) returns the directory in which the current
1441 -- executable, which should be called 'cmd', is running
1442 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1443 -- you'll get "/a/b/c" back as the result
1444 getExecDir :: String -> IO (Maybe String)
1446 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1447 where initN n = reverse . drop n . reverse
1448 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1450 getExecPath :: IO (Maybe String)
1452 allocaArray len $ \buf -> do
1453 ret <- getModuleFileName nullPtr buf len
1454 if ret == 0 then return Nothing
1455 else liftM Just $ peekCString buf
1456 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1458 foreign import stdcall unsafe "GetModuleFileNameA"
1459 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1462 getLibDir :: IO (Maybe String)
1463 getLibDir = return Nothing
1466 -----------------------------------------
1467 -- Adapted from ghc/compiler/utils/Panic
1469 installSignalHandlers :: IO ()
1470 installSignalHandlers = do
1471 threadid <- myThreadId
1473 interrupt = Exception.throwTo threadid
1474 (Exception.ErrorCall "interrupted")
1476 #if !defined(mingw32_HOST_OS)
1477 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1478 _ <- installHandler sigINT (Catch interrupt) Nothing
1480 #elif __GLASGOW_HASKELL__ >= 603
1481 -- GHC 6.3+ has support for console events on Windows
1482 -- NOTE: running GHCi under a bash shell for some reason requires
1483 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1484 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1485 -- why --SDM 17/12/2004
1486 let sig_handler ControlC = interrupt
1487 sig_handler Break = interrupt
1488 sig_handler _ = return ()
1490 _ <- installHandler (Catch sig_handler)
1493 return () -- nothing
1496 #if __GLASGOW_HASKELL__ <= 604
1497 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1498 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1501 #if mingw32_HOST_OS || mingw32_TARGET_OS
1502 throwIOIO :: Exception.IOException -> IO a
1503 throwIOIO = Exception.throwIO
1505 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1506 catchIO = Exception.catch
1509 catchError :: IO a -> (String -> IO a) -> IO a
1510 catchError io handler = io `Exception.catch` handler'
1511 where handler' (Exception.ErrorCall err) = handler err
1514 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1515 -- to use text files here, rather than binary files.
1516 writeFileAtomic :: FilePath -> String -> IO ()
1517 writeFileAtomic targetFile content = do
1518 (newFile, newHandle) <- openNewFile targetDir template
1519 do hPutStr newHandle content
1521 #if mingw32_HOST_OS || mingw32_TARGET_OS
1522 renameFile newFile targetFile
1523 -- If the targetFile exists then renameFile will fail
1524 `catchIO` \err -> do
1525 exists <- doesFileExist targetFile
1527 then do removeFile targetFile
1528 -- Big fat hairy race condition
1529 renameFile newFile targetFile
1530 -- If the removeFile succeeds and the renameFile fails
1531 -- then we've lost the atomic property.
1534 renameFile newFile targetFile
1536 `Exception.onException` do hClose newHandle
1539 template = targetName <.> "tmp"
1540 targetDir | null targetDir_ = "."
1541 | otherwise = targetDir_
1542 --TODO: remove this when takeDirectory/splitFileName is fixed
1543 -- to always return a valid dir
1544 (targetDir_,targetName) = splitFileName targetFile
1546 -- Ugh, this is a copy/paste of code from the base library, but
1547 -- if uses 666 rather than 600 for the permissions.
1548 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1549 openNewFile dir template = do
1553 -- We split off the last extension, so we can use .foo.ext files
1554 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1555 -- below filepath in the hierarchy here.
1557 case break (== '.') $ reverse template of
1558 -- First case: template contains no '.'s. Just re-reverse it.
1559 (rev_suffix, "") -> (reverse rev_suffix, "")
1560 -- Second case: template contains at least one '.'. Strip the
1561 -- dot from the prefix and prepend it to the suffix (if we don't
1562 -- do this, the unique number will get added after the '.' and
1563 -- thus be part of the extension, which is wrong.)
1564 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1565 -- Otherwise, something is wrong, because (break (== '.')) should
1566 -- always return a pair with either the empty string or a string
1567 -- beginning with '.' as the second component.
1568 _ -> error "bug in System.IO.openTempFile"
1570 oflags = rw_flags .|. o_EXCL
1572 #if __GLASGOW_HASKELL__ < 611
1573 withFilePath = withCString
1577 fd <- withFilePath filepath $ \ f ->
1578 c_open f oflags 0o666
1583 then findTempName (x+1)
1584 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1586 -- XXX We want to tell fdToHandle what the filepath is,
1587 -- as any exceptions etc will only be able to report the
1590 #if __GLASGOW_HASKELL__ >= 609
1593 fdToHandle (fromIntegral fd)
1595 `Exception.onException` c_close fd
1596 return (filepath, h)
1598 filename = prefix ++ show x ++ suffix
1599 filepath = dir `combine` filename
1601 -- XXX Copied from GHC.Handle
1602 std_flags, output_flags, rw_flags :: CInt
1603 std_flags = o_NONBLOCK .|. o_NOCTTY
1604 output_flags = std_flags .|. o_CREAT
1605 rw_flags = output_flags .|. o_RDWR
1607 -- | The function splits the given string to substrings
1608 -- using 'isSearchPathSeparator'.
1609 parseSearchPath :: String -> [FilePath]
1610 parseSearchPath path = split path
1612 split :: String -> [String]
1616 _:rest -> chunk : split rest
1620 #ifdef mingw32_HOST_OS
1621 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1625 (chunk', rest') = break isSearchPathSeparator s