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. The input file should be encoded in UTF-8.\n" ++
187 " $p update {filename | -}\n" ++
188 " Register the package, overwriting any other package with the\n" ++
189 " same name. The input file should be encoded in UTF-8.\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. The output is\n" ++
237 " always encoded in UTF-8, regardless of the current locale.\n" ++
240 " Regenerate the package database cache. This command should only be\n" ++
241 " necessary if you added a package to the database by dropping a file\n" ++
242 " into the database directory manually. By default, the global DB\n" ++
243 " is recached; to recache a different DB use --user or --package-conf\n" ++
244 " as appropriate.\n" ++
246 " Substring matching is supported for {module} in find-module and\n" ++
247 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
248 " open substring ends (prefix*, *suffix, *infix*).\n" ++
250 " When asked to modify a database (register, unregister, update,\n"++
251 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
252 " default. Specifying --user causes it to act on the user database,\n"++
253 " or --package-conf can be used to act on another database\n"++
254 " entirely. When multiple of these options are given, the rightmost\n"++
255 " one is used as the database to act upon.\n"++
257 " Commands that query the package database (list, tree, latest, describe,\n"++
258 " field) operate on the list of databases specified by the flags\n"++
259 " --user, --global, and --package-conf. If none of these flags are\n"++
260 " given, the default is --global --user.\n"++
262 " The following optional flags are also accepted:\n"
264 substProg :: String -> String -> String
266 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
267 substProg prog (c:xs) = c : substProg prog xs
269 -- -----------------------------------------------------------------------------
272 data Force = NoForce | ForceFiles | ForceAll | CannotForce
275 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
277 runit :: Verbosity -> [Flag] -> [String] -> IO ()
278 runit verbosity cli nonopts = do
279 installSignalHandlers -- catch ^C and clean up
280 prog <- getProgramName
283 | FlagForce `elem` cli = ForceAll
284 | FlagForceFiles `elem` cli = ForceFiles
285 | otherwise = NoForce
286 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
287 splitFields fields = unfoldr splitComma (',':fields)
288 where splitComma "" = Nothing
289 splitComma fs = Just $ break (==',') (tail fs)
291 substringCheck :: String -> Maybe (String -> Bool)
292 substringCheck "" = Nothing
293 substringCheck "*" = Just (const True)
294 substringCheck [_] = Nothing
295 substringCheck (h:t) =
296 case (h, init t, last t) of
297 ('*',s,'*') -> Just (isInfixOf (f s) . f)
298 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
299 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
301 where f | FlagIgnoreCase `elem` cli = map toLower
304 glob x | System.Info.os=="mingw32" = do
305 -- glob echoes its argument, after win32 filename globbing
306 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
307 txt <- hGetContents o
309 glob x | otherwise = return [x]
312 -- first, parse the command
315 -- dummy command to demonstrate usage and permit testing
316 -- without messing things up; use glob to selectively enable
317 -- windows filename globbing for file parameters
318 -- register, update, FlagGlobalConfig, FlagConfig; others?
319 ["glob", filename] -> do
321 glob filename >>= print
323 ["init", filename] ->
324 initPackageDB filename verbosity cli
325 ["register", filename] ->
326 registerPackage filename verbosity cli auto_ghci_libs False force
327 ["update", filename] ->
328 registerPackage filename verbosity cli auto_ghci_libs True force
329 ["unregister", pkgid_str] -> do
330 pkgid <- readGlobPkgId pkgid_str
331 unregisterPackage pkgid verbosity cli force
332 ["expose", pkgid_str] -> do
333 pkgid <- readGlobPkgId pkgid_str
334 exposePackage pkgid verbosity cli force
335 ["hide", pkgid_str] -> do
336 pkgid <- readGlobPkgId pkgid_str
337 hidePackage pkgid verbosity cli force
339 listPackages verbosity cli Nothing Nothing
340 ["list", pkgid_str] ->
341 case substringCheck pkgid_str of
342 Nothing -> do pkgid <- readGlobPkgId pkgid_str
343 listPackages verbosity cli (Just (Id pkgid)) Nothing
344 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
346 showPackageDot verbosity cli
347 ["find-module", moduleName] -> do
348 let match = maybe (==moduleName) id (substringCheck moduleName)
349 listPackages verbosity cli Nothing (Just match)
350 ["latest", pkgid_str] -> do
351 pkgid <- readGlobPkgId pkgid_str
352 latestPackage verbosity cli pkgid
353 ["describe", pkgid_str] ->
354 case substringCheck pkgid_str of
355 Nothing -> do pkgid <- readGlobPkgId pkgid_str
356 describePackage verbosity cli (Id pkgid)
357 Just m -> describePackage verbosity cli (Substring pkgid_str m)
358 ["field", pkgid_str, fields] ->
359 case substringCheck pkgid_str of
360 Nothing -> do pkgid <- readGlobPkgId pkgid_str
361 describeField verbosity cli (Id pkgid)
363 Just m -> describeField verbosity cli (Substring pkgid_str m)
366 checkConsistency verbosity cli
369 dumpPackages verbosity cli
372 recache verbosity cli
375 die ("missing command\n" ++
376 usageInfo (usageHeader prog) flags)
378 die ("command-line syntax error\n" ++
379 usageInfo (usageHeader prog) flags)
381 parseCheck :: ReadP a a -> String -> String -> IO a
382 parseCheck parser str what =
383 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
385 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
387 readGlobPkgId :: String -> IO PackageIdentifier
388 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
390 parseGlobPackageId :: ReadP r PackageIdentifier
396 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
398 -- globVersion means "all versions"
399 globVersion :: Version
400 globVersion = Version{ versionBranch=[], versionTags=["*"] }
402 -- -----------------------------------------------------------------------------
405 -- Some commands operate on a single database:
406 -- register, unregister, expose, hide
407 -- however these commands also check the union of the available databases
408 -- in order to check consistency. For example, register will check that
409 -- dependencies exist before registering a package.
411 -- Some commands operate on multiple databases, with overlapping semantics:
412 -- list, describe, field
415 = PackageDB { location :: FilePath,
416 packages :: [InstalledPackageInfo] }
418 type PackageDBStack = [PackageDB]
419 -- A stack of package databases. Convention: head is the topmost
422 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
423 allPackagesInStack = concatMap packages
425 getPkgDatabases :: Verbosity
426 -> Bool -- we are modifying, not reading
427 -> Bool -- read caches, if available
429 -> IO (PackageDBStack,
430 -- the real package DB stack: [global,user] ++
431 -- DBs specified on the command line with -f.
433 -- which one to modify, if any
435 -- the package DBs specified on the command
436 -- line, or [global,user] otherwise. This
437 -- is used as the list of package DBs for
438 -- commands that just read the DB, such as 'list'.
440 getPkgDatabases verbosity modify use_cache my_flags = do
441 -- first we determine the location of the global package config. On Windows,
442 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
443 -- location is passed to the binary using the --global-config flag by the
445 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
447 case [ f | FlagGlobalConfig f <- my_flags ] of
448 [] -> do mb_dir <- getLibDir
450 Nothing -> die err_msg
452 r <- lookForPackageDBIn dir
454 Nothing -> die ("Can't find package database in " ++ dir)
455 Just path -> return path
456 fs -> return (last fs)
458 let no_user_db = FlagNoUserDb `elem` my_flags
460 -- get the location of the user package database, and create it if necessary
461 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
462 e_appdir <- try $ getAppUserDataDirectory "ghc"
465 if no_user_db then return Nothing else
467 Left _ -> return Nothing
469 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
470 dir = appdir </> subdir
471 r <- lookForPackageDBIn dir
473 Nothing -> return (Just (dir </> "package.conf.d", False))
474 Just f -> return (Just (f, True))
476 -- If the user database doesn't exist, and this command isn't a
477 -- "modify" command, then we won't attempt to create or use it.
479 | Just (user_conf,user_exists) <- mb_user_conf,
480 modify || user_exists = [user_conf, global_conf]
481 | otherwise = [global_conf]
483 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
486 Left _ -> sys_databases
488 | last cs == "" -> init cs ++ sys_databases
490 where cs = parseSearchPath path
492 -- The "global" database is always the one at the bottom of the stack.
493 -- This is the database we modify by default.
494 virt_global_conf = last env_stack
496 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
497 where is_db_flag FlagUser
498 | Just (user_conf, _user_exists) <- mb_user_conf
500 is_db_flag FlagGlobal = Just virt_global_conf
501 is_db_flag (FlagConfig f) = Just f
502 is_db_flag _ = Nothing
504 let flag_db_names | null db_flags = env_stack
505 | otherwise = reverse (nub db_flags)
507 -- For a "modify" command, treat all the databases as
508 -- a stack, where we are modifying the top one, but it
509 -- can refer to packages in databases further down the
512 -- -f flags on the command line add to the database
513 -- stack, unless any of them are present in the stack
515 let final_stack = filter (`notElem` env_stack)
516 [ f | FlagConfig f <- reverse my_flags ]
519 -- the database we actually modify is the one mentioned
520 -- rightmost on the command-line.
522 | not modify = Nothing
523 | null db_flags = Just virt_global_conf
524 | otherwise = Just (last db_flags)
526 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
528 let flag_db_stack = [ db | db_name <- flag_db_names,
529 db <- db_stack, location db == db_name ]
531 return (db_stack, to_modify, flag_db_stack)
534 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
535 lookForPackageDBIn dir = do
536 let path_dir = dir </> "package.conf.d"
537 exists_dir <- doesDirectoryExist path_dir
538 if exists_dir then return (Just path_dir) else do
539 let path_file = dir </> "package.conf"
540 exists_file <- doesFileExist path_file
541 if exists_file then return (Just path_file) else return Nothing
543 readParseDatabase :: Verbosity
544 -> Maybe (FilePath,Bool)
549 readParseDatabase verbosity mb_user_conf use_cache path
550 -- the user database (only) is allowed to be non-existent
551 | Just (user_conf,False) <- mb_user_conf, path == user_conf
552 = return PackageDB { location = path, packages = [] }
554 = do e <- try $ getDirectoryContents path
557 pkgs <- parseMultiPackageConf verbosity path
558 return PackageDB{ location = path, packages = pkgs }
560 | not use_cache -> ignore_cache
562 let cache = path </> cachefilename
563 tdir <- getModificationTime path
564 e_tcache <- try $ getModificationTime cache
567 when (verbosity > Normal) $
568 putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
571 | tcache >= tdir -> do
572 when (verbosity > Normal) $
573 putStrLn ("using cache: " ++ cache)
574 pkgs <- myReadBinPackageDB cache
575 let pkgs' = map convertPackageInfoIn pkgs
576 return PackageDB { location = path, packages = pkgs' }
578 when (verbosity >= Normal) $ do
579 putStrLn ("WARNING: cache is out of date: " ++ cache)
580 putStrLn " use 'ghc-pkg recache' to fix."
584 let confs = filter (".conf" `isSuffixOf`) fs
585 pkgs <- mapM (parseSingletonPackageConf verbosity) $
587 return PackageDB { location = path, packages = pkgs }
589 -- read the package.cache file strictly, to work around a problem with
590 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
591 -- after it has been completely read, leading to a sharing violation
593 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
594 myReadBinPackageDB filepath = do
595 h <- openBinaryFile filepath ReadMode
597 b <- B.hGet h (fromIntegral sz)
599 return $ Bin.runGet Bin.get b
601 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
602 parseMultiPackageConf verbosity file = do
603 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
604 str <- readUTF8File file
605 let pkgs = map convertPackageInfoIn $ read str
606 Exception.evaluate pkgs
608 die ("error while parsing " ++ file ++ ": " ++ show e)
610 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
611 parseSingletonPackageConf verbosity file = do
612 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
613 readUTF8File file >>= parsePackageInfo
615 cachefilename :: FilePath
616 cachefilename = "package.cache"
618 -- -----------------------------------------------------------------------------
619 -- Creating a new package DB
621 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
622 initPackageDB filename verbosity _flags = do
623 let eexist = die ("cannot create: " ++ filename ++ " already exists")
624 b1 <- doesFileExist filename
626 b2 <- doesDirectoryExist filename
628 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
630 -- -----------------------------------------------------------------------------
633 registerPackage :: FilePath
636 -> Bool -- auto_ghci_libs
640 registerPackage input verbosity my_flags auto_ghci_libs update force = do
641 (db_stack, Just to_modify, _flag_dbs) <-
642 getPkgDatabases verbosity True True my_flags
645 db_to_operate_on = my_head "register" $
646 filter ((== to_modify).location) db_stack
651 when (verbosity >= Normal) $
652 putStr "Reading package info from stdin ... "
653 #if __GLASGOW_HASKELL__ >= 612
654 -- fix the encoding to UTF-8, since this is an interchange format
655 hSetEncoding stdin utf8
659 when (verbosity >= Normal) $
660 putStr ("Reading package info from " ++ show f ++ " ... ")
663 expanded <- expandEnvVars s force
665 pkg <- parsePackageInfo expanded
666 when (verbosity >= Normal) $
669 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
670 -- truncate the stack for validation, because we don't allow
671 -- packages lower in the stack to refer to those higher up.
672 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
674 removes = [ RemovePackage p
675 | p <- packages db_to_operate_on,
676 sourcePackageId p == sourcePackageId pkg ]
678 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
682 -> IO InstalledPackageInfo
683 parsePackageInfo str =
684 case parseInstalledPackageInfo str of
685 ParseOk _warns ok -> return ok
686 ParseFailed err -> case locatedErrorMsg err of
687 (Nothing, s) -> die s
688 (Just l, s) -> die (show l ++ ": " ++ s)
690 -- -----------------------------------------------------------------------------
691 -- Making changes to a package database
693 data DBOp = RemovePackage InstalledPackageInfo
694 | AddPackage InstalledPackageInfo
695 | ModifyPackage InstalledPackageInfo
697 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
698 changeDB verbosity cmds db = do
699 let db' = updateInternalDB db cmds
700 isfile <- doesFileExist (location db)
702 then writeNewConfig verbosity (location db') (packages db')
704 createDirectoryIfMissing True (location db)
705 changeDBDir verbosity cmds db'
707 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
708 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
710 do_cmd pkgs (RemovePackage p) =
711 filter ((/= installedPackageId p) . installedPackageId) pkgs
712 do_cmd pkgs (AddPackage p) = p : pkgs
713 do_cmd pkgs (ModifyPackage p) =
714 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
717 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
718 changeDBDir verbosity cmds db = do
720 updateDBCache verbosity db
722 do_cmd (RemovePackage p) = do
723 let file = location db </> display (installedPackageId p) <.> "conf"
724 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
726 do_cmd (AddPackage p) = do
727 let file = location db </> display (installedPackageId p) <.> "conf"
728 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
729 writeFileAtomic file (showInstalledPackageInfo p)
730 do_cmd (ModifyPackage p) =
731 do_cmd (AddPackage p)
733 updateDBCache :: Verbosity -> PackageDB -> IO ()
734 updateDBCache verbosity db = do
735 let filename = location db </> cachefilename
736 when (verbosity > Normal) $
737 putStrLn ("writing cache " ++ filename)
738 writeBinPackageDB filename (map convertPackageInfoOut (packages db))
740 if isPermissionError e
741 then die (filename ++ ": you don't have permission to modify this file")
744 -- -----------------------------------------------------------------------------
745 -- Exposing, Hiding, Unregistering are all similar
747 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
748 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
750 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
751 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
753 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
754 unregisterPackage = modifyPackage RemovePackage
757 :: (InstalledPackageInfo -> DBOp)
763 modifyPackage fn pkgid verbosity my_flags force = do
764 (db_stack, Just _to_modify, _flag_dbs) <-
765 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
767 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
769 db_name = location db
772 pids = map sourcePackageId ps
774 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
775 new_db = updateInternalDB db cmds
777 old_broken = brokenPackages (allPackagesInStack db_stack)
778 rest_of_stack = filter ((/= db_name) . location) db_stack
779 new_stack = new_db : rest_of_stack
780 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
781 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
783 when (not (null newly_broken)) $
784 dieOrForceAll force ("unregistering " ++ display pkgid ++
785 " would break the following packages: "
786 ++ unwords (map display newly_broken))
788 changeDB verbosity cmds db
790 recache :: Verbosity -> [Flag] -> IO ()
791 recache verbosity my_flags = do
792 (db_stack, Just to_modify, _flag_dbs) <-
793 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
795 db_to_operate_on = my_head "recache" $
796 filter ((== to_modify).location) db_stack
798 changeDB verbosity [] db_to_operate_on
800 -- -----------------------------------------------------------------------------
803 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
804 -> Maybe (String->Bool)
806 listPackages verbosity my_flags mPackageName mModuleName = do
807 let simple_output = FlagSimpleOutput `elem` my_flags
808 (db_stack, _, flag_db_stack) <-
809 getPkgDatabases verbosity False True{-use cache-} my_flags
811 let db_stack_filtered -- if a package is given, filter out all other packages
812 | Just this <- mPackageName =
813 [ db{ packages = filter (this `matchesPkg`) (packages db) }
814 | db <- flag_db_stack ]
815 | Just match <- mModuleName = -- packages which expose mModuleName
816 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
817 | db <- flag_db_stack ]
818 | otherwise = flag_db_stack
821 = [ db{ packages = sort_pkgs (packages db) }
822 | db <- db_stack_filtered ]
823 where sort_pkgs = sortBy cmpPkgIds
824 cmpPkgIds pkg1 pkg2 =
825 case pkgName p1 `compare` pkgName p2 of
828 EQ -> pkgVersion p1 `compare` pkgVersion p2
829 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
831 stack = reverse db_stack_sorted
833 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
835 pkg_map = allPackagesInStack db_stack
836 broken = map sourcePackageId (brokenPackages pkg_map)
838 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
839 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
841 pp_pkgs = map pp_pkg pkg_confs
843 | sourcePackageId p `elem` broken = printf "{%s}" doc
845 | otherwise = printf "(%s)" doc
846 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
849 InstalledPackageId ipid = installedPackageId p
850 pkg = display (sourcePackageId p)
852 show_simple = simplePackageList my_flags . allPackagesInStack
854 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
855 prog <- getProgramName
856 putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
858 if simple_output then show_simple stack else do
860 #if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
861 mapM_ show_normal stack
864 show_colour withF db =
865 mconcat $ map (<#> termText "\n") $
866 (termText (location db) :
867 map (termText " " <#>) (map pp_pkg (packages db)))
870 | sourcePackageId p `elem` broken = withF Red doc
872 | otherwise = withF Blue doc
873 where doc | verbosity >= Verbose
874 = termText (printf "%s (%s)" pkg ipid)
878 InstalledPackageId ipid = installedPackageId p
879 pkg = display (sourcePackageId p)
881 is_tty <- hIsTerminalDevice stdout
883 then mapM_ show_normal stack
884 else do tty <- Terminfo.setupTermFromEnv
885 case Terminfo.getCapability tty withForegroundColor of
886 Nothing -> mapM_ show_normal stack
887 Just w -> runTermOutput tty $ mconcat $
888 map (show_colour w) stack
891 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
892 simplePackageList my_flags pkgs = do
893 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
895 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
896 when (not (null pkgs)) $
897 hPutStrLn stdout $ concat $ intersperse " " strs
899 showPackageDot :: Verbosity -> [Flag] -> IO ()
900 showPackageDot verbosity myflags = do
901 (_, _, flag_db_stack) <-
902 getPkgDatabases verbosity False True{-use cache-} myflags
904 let all_pkgs = allPackagesInStack flag_db_stack
905 ipix = PackageIndex.fromList all_pkgs
908 let quote s = '"':s ++ "\""
909 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
911 let from = display (sourcePackageId p),
913 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
914 let to = display (sourcePackageId dep)
918 -- -----------------------------------------------------------------------------
919 -- Prints the highest (hidden or exposed) version of a package
921 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
922 latestPackage verbosity my_flags pkgid = do
923 (_, _, flag_db_stack) <-
924 getPkgDatabases verbosity False True{-use cache-} my_flags
926 ps <- findPackages flag_db_stack (Id pkgid)
927 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
929 show_pkg [] = die "no matches"
930 show_pkg pids = hPutStrLn stdout (display (last pids))
932 -- -----------------------------------------------------------------------------
935 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
936 describePackage verbosity my_flags pkgarg = do
937 (_, _, flag_db_stack) <-
938 getPkgDatabases verbosity False True{-use cache-} my_flags
939 ps <- findPackages flag_db_stack pkgarg
942 dumpPackages :: Verbosity -> [Flag] -> IO ()
943 dumpPackages verbosity my_flags = do
944 (_, _, flag_db_stack) <-
945 getPkgDatabases verbosity False True{-use cache-} my_flags
946 doDump (allPackagesInStack flag_db_stack)
948 doDump :: [InstalledPackageInfo] -> IO ()
950 #if __GLASGOW_HASKELL__ >= 612
951 -- fix the encoding to UTF-8, since this is an interchange format
952 hSetEncoding stdout utf8
954 mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
956 -- PackageId is can have globVersion for the version
957 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
958 findPackages db_stack pkgarg
959 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
961 findPackagesByDB :: PackageDBStack -> PackageArg
962 -> IO [(PackageDB, [InstalledPackageInfo])]
963 findPackagesByDB db_stack pkgarg
964 = case [ (db, matched)
966 let matched = filter (pkgarg `matchesPkg`) (packages db),
967 not (null matched) ] of
968 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
971 pkg_msg (Id pkgid) = display pkgid
972 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
974 matches :: PackageIdentifier -> PackageIdentifier -> Bool
976 = (pkgName pid == pkgName pid')
977 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
979 realVersion :: PackageIdentifier -> Bool
980 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
981 -- when versionBranch == [], this is a glob
983 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
984 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
985 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
987 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
988 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
990 -- -----------------------------------------------------------------------------
993 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
994 describeField verbosity my_flags pkgarg fields = do
995 (_, _, flag_db_stack) <-
996 getPkgDatabases verbosity False True{-use cache-} my_flags
997 fns <- toFields fields
998 ps <- findPackages flag_db_stack pkgarg
999 let top_dir = takeDirectory (location (last flag_db_stack))
1000 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
1001 where toFields [] = return []
1002 toFields (f:fs) = case toField f of
1003 Nothing -> die ("unknown field: " ++ f)
1004 Just fn -> do fns <- toFields fs
1006 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1008 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1009 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1010 -- with the current topdir (obtained from the -B option).
1011 mungePackagePaths top_dir ps = map munge_pkg ps
1013 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
1014 includeDirs = munge_paths (includeDirs p),
1015 libraryDirs = munge_paths (libraryDirs p),
1016 frameworkDirs = munge_paths (frameworkDirs p),
1017 haddockInterfaces = munge_paths (haddockInterfaces p),
1018 haddockHTMLs = munge_paths (haddockHTMLs p)
1021 munge_paths = map munge_path
1024 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1025 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1028 toHttpPath p = "file:///" ++ p
1030 maybePrefixMatch :: String -> String -> Maybe String
1031 maybePrefixMatch [] rest = Just rest
1032 maybePrefixMatch (_:_) [] = Nothing
1033 maybePrefixMatch (p:pat) (r:rest)
1034 | p == r = maybePrefixMatch pat rest
1035 | otherwise = Nothing
1037 toField :: String -> Maybe (InstalledPackageInfo -> String)
1038 -- backwards compatibility:
1039 toField "import_dirs" = Just $ strList . importDirs
1040 toField "source_dirs" = Just $ strList . importDirs
1041 toField "library_dirs" = Just $ strList . libraryDirs
1042 toField "hs_libraries" = Just $ strList . hsLibraries
1043 toField "extra_libraries" = Just $ strList . extraLibraries
1044 toField "include_dirs" = Just $ strList . includeDirs
1045 toField "c_includes" = Just $ strList . includes
1046 toField "package_deps" = Just $ strList . map display. depends
1047 toField "extra_cc_opts" = Just $ strList . ccOptions
1048 toField "extra_ld_opts" = Just $ strList . ldOptions
1049 toField "framework_dirs" = Just $ strList . frameworkDirs
1050 toField "extra_frameworks"= Just $ strList . frameworks
1051 toField s = showInstalledPackageInfoField s
1053 strList :: [String] -> String
1057 -- -----------------------------------------------------------------------------
1058 -- Check: Check consistency of installed packages
1060 checkConsistency :: Verbosity -> [Flag] -> IO ()
1061 checkConsistency verbosity my_flags = do
1062 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1063 -- check behaves like modify for the purposes of deciding which
1064 -- databases to use, because ordering is important.
1066 let simple_output = FlagSimpleOutput `elem` my_flags
1068 let pkgs = allPackagesInStack db_stack
1071 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
1075 when (not simple_output) $ do
1076 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1077 _ <- reportValidateErrors es " " Nothing
1081 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1083 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1084 where not_in p = sourcePackageId p `notElem` all_ps
1085 all_ps = map sourcePackageId pkgs1
1087 let not_broken_pkgs = filterOut broken_pkgs pkgs
1088 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1089 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1091 when (not (null all_broken_pkgs)) $ do
1093 then simplePackageList my_flags all_broken_pkgs
1095 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1096 "listed above, or because they depend on a broken package.")
1097 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1099 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1102 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1103 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1104 closure pkgs db_stack = go pkgs db_stack
1106 go avail not_avail =
1107 case partition (depsAvailable avail) not_avail of
1108 ([], not_avail') -> (avail, not_avail')
1109 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1111 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1113 depsAvailable pkgs_ok pkg = null dangling
1114 where dangling = filter (`notElem` pids) (depends pkg)
1115 pids = map installedPackageId pkgs_ok
1117 -- we want mutually recursive groups of package to show up
1118 -- as broken. (#1750)
1120 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1121 brokenPackages pkgs = snd (closure [] pkgs)
1123 -- -----------------------------------------------------------------------------
1124 -- Manipulating package.conf files
1126 type InstalledPackageInfoString = InstalledPackageInfo_ String
1128 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1129 convertPackageInfoOut
1130 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1131 hiddenModules = h })) =
1132 pkgconf{ exposedModules = map display e,
1133 hiddenModules = map display h }
1135 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1136 convertPackageInfoIn
1137 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1138 hiddenModules = h })) =
1139 pkgconf{ exposedModules = map convert e,
1140 hiddenModules = map convert h }
1141 where convert = fromJust . simpleParse
1143 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1144 writeNewConfig verbosity filename ipis = do
1145 when (verbosity >= Normal) $
1146 hPutStr stdout "Writing new package config file... "
1147 createDirectoryIfMissing True $ takeDirectory filename
1148 let shown = concat $ intersperse ",\n "
1149 $ map (show . convertPackageInfoOut) ipis
1150 fileContents = "[" ++ shown ++ "\n]"
1151 writeFileAtomic filename fileContents
1153 if isPermissionError e
1154 then die (filename ++ ": you don't have permission to modify this file")
1156 when (verbosity >= Normal) $
1157 hPutStrLn stdout "done."
1159 -----------------------------------------------------------------------------
1160 -- Sanity-check a new package config, and automatically build GHCi libs
1163 type ValidateError = (Force,String)
1165 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
1167 instance Monad Validate where
1168 return a = V $ return (a, [])
1170 (a, es) <- runValidate m
1171 (b, es') <- runValidate (k a)
1174 verror :: Force -> String -> Validate ()
1175 verror f s = V (return ((),[(f,s)]))
1177 liftIO :: IO a -> Validate a
1178 liftIO k = V (k >>= \a -> return (a,[]))
1180 -- returns False if we should die
1181 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
1182 reportValidateErrors es prefix mb_force = do
1183 oks <- mapM report es
1187 | Just force <- mb_force
1189 then do reportError (prefix ++ s ++ " (ignoring)")
1191 else if f < CannotForce
1192 then do reportError (prefix ++ s ++ " (use --force to override)")
1194 else do reportError err
1196 | otherwise = do reportError err
1201 validatePackageConfig :: InstalledPackageInfo
1203 -> Bool -- auto-ghc-libs
1204 -> Bool -- update, or check
1207 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1208 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1209 ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
1210 when (not ok) $ exitWith (ExitFailure 1)
1212 checkPackageConfig :: InstalledPackageInfo
1214 -> Bool -- auto-ghc-libs
1215 -> Bool -- update, or check
1217 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1218 checkInstalledPackageId pkg db_stack update
1220 checkDuplicates db_stack pkg update
1221 mapM_ (checkDep db_stack) (depends pkg)
1222 checkDuplicateDepends (depends pkg)
1223 mapM_ (checkDir "import-dirs") (importDirs pkg)
1224 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
1225 mapM_ (checkDir "include-dirs") (includeDirs pkg)
1227 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1228 -- ToDo: check these somehow?
1229 -- extra_libraries :: [String],
1230 -- c_includes :: [String],
1232 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1234 checkInstalledPackageId ipi db_stack update = do
1235 let ipid@(InstalledPackageId str) = installedPackageId ipi
1236 when (null str) $ verror CannotForce "missing id field"
1237 let dups = [ p | p <- allPackagesInStack db_stack,
1238 installedPackageId p == ipid ]
1239 when (not update && not (null dups)) $
1240 verror CannotForce $
1241 "package(s) with this id already exist: " ++
1242 unwords (map (display.packageId) dups)
1244 -- When the package name and version are put together, sometimes we can
1245 -- end up with a package id that cannot be parsed. This will lead to
1246 -- difficulties when the user wants to refer to the package later, so
1247 -- we check that the package id can be parsed properly here.
1248 checkPackageId :: InstalledPackageInfo -> Validate ()
1249 checkPackageId ipi =
1250 let str = display (sourcePackageId ipi) in
1251 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1253 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1254 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1256 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1257 checkDuplicates db_stack pkg update = do
1259 pkgid = sourcePackageId pkg
1260 pkgs = packages (head db_stack)
1262 -- Check whether this package id already exists in this DB
1264 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1265 verror CannotForce $
1266 "package " ++ display pkgid ++ " is already installed"
1269 uncasep = map toLower . display
1270 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1272 when (not update && not (null dups)) $ verror ForceAll $
1273 "Package names may be treated case-insensitively in the future.\n"++
1274 "Package " ++ display pkgid ++
1275 " overlaps with: " ++ unwords (map display dups)
1278 checkDir :: String -> String -> Validate ()
1279 checkDir thisfield d
1280 | "$topdir" `isPrefixOf` d = return ()
1281 | "$httptopdir" `isPrefixOf` d = return ()
1282 -- can't check these, because we don't know what $(http)topdir is
1284 there <- liftIO $ doesDirectoryExist d
1286 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1288 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1289 checkDep db_stack pkgid
1290 | pkgid `elem` pkgids = return ()
1291 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1292 ++ "\" doesn't exist")
1294 all_pkgs = allPackagesInStack db_stack
1295 pkgids = map installedPackageId all_pkgs
1297 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1298 checkDuplicateDepends deps
1299 | null dups = return ()
1300 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1301 unwords (map display dups))
1303 dups = [ p | (p:_:_) <- group (sort deps) ]
1305 checkHSLib :: [String] -> Bool -> String -> Validate ()
1306 checkHSLib dirs auto_ghci_libs lib = do
1307 let batch_lib_file = "lib" ++ lib ++ ".a"
1308 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1310 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1312 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1314 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1315 doesFileExistOnPath file path = go path
1316 where go [] = return Nothing
1317 go (p:ps) = do b <- doesFileExistIn file p
1318 if b then return (Just p) else go ps
1320 doesFileExistIn :: String -> String -> IO Bool
1321 doesFileExistIn lib d
1322 | "$topdir" `isPrefixOf` d = return True
1323 | "$httptopdir" `isPrefixOf` d = return True
1324 | otherwise = doesFileExist (d </> lib)
1326 checkModules :: InstalledPackageInfo -> Validate ()
1327 checkModules pkg = do
1328 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1330 findModule modl = do
1331 -- there's no .hi file for GHC.Prim
1332 if modl == fromString "GHC.Prim" then return () else do
1333 let file = toFilePath modl <.> "hi"
1334 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1335 when (isNothing m) $
1336 verror ForceFiles ("file " ++ file ++ " is missing")
1338 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1339 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1340 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1342 m <- doesFileExistOnPath ghci_lib_file dirs
1343 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1344 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1346 ghci_lib_file = lib <.> "o"
1348 -- automatically build the GHCi version of a batch lib,
1349 -- using ld --whole-archive.
1351 autoBuildGHCiLib :: String -> String -> String -> IO ()
1352 autoBuildGHCiLib dir batch_file ghci_file = do
1353 let ghci_lib_file = dir ++ '/':ghci_file
1354 batch_lib_file = dir ++ '/':batch_file
1355 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1356 #if defined(darwin_HOST_OS)
1357 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1358 #elif defined(mingw32_HOST_OS)
1359 execDir <- getLibDir
1360 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1362 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1364 when (r /= ExitSuccess) $ exitWith r
1365 hPutStrLn stderr (" done.")
1367 -- -----------------------------------------------------------------------------
1368 -- Searching for modules
1372 findModules :: [FilePath] -> IO [String]
1374 mms <- mapM searchDir paths
1377 searchDir path prefix = do
1378 fs <- getDirectoryEntries path `catch` \_ -> return []
1379 searchEntries path prefix fs
1381 searchEntries path prefix [] = return []
1382 searchEntries path prefix (f:fs)
1383 | looks_like_a_module = do
1384 ms <- searchEntries path prefix fs
1385 return (prefix `joinModule` f : ms)
1386 | looks_like_a_component = do
1387 ms <- searchDir (path </> f) (prefix `joinModule` f)
1388 ms' <- searchEntries path prefix fs
1391 searchEntries path prefix fs
1394 (base,suffix) = splitFileExt f
1395 looks_like_a_module =
1396 suffix `elem` haskell_suffixes &&
1397 all okInModuleName base
1398 looks_like_a_component =
1399 null suffix && all okInModuleName base
1405 -- ---------------------------------------------------------------------------
1406 -- expanding environment variables in the package configuration
1408 expandEnvVars :: String -> Force -> IO String
1409 expandEnvVars str0 force = go str0 ""
1411 go "" acc = return $! reverse acc
1412 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1413 = do value <- lookupEnvVar var
1414 go rest (reverse value ++ acc)
1415 where close c = c == '}' || c == '\n' -- don't span newlines
1419 lookupEnvVar :: String -> IO String
1421 catch (System.Environment.getEnv nm)
1422 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1426 -----------------------------------------------------------------------------
1428 getProgramName :: IO String
1429 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1430 where str `withoutSuffix` suff
1431 | suff `isSuffixOf` str = take (length str - length suff) str
1434 bye :: String -> IO a
1435 bye s = putStr s >> exitWith ExitSuccess
1437 die :: String -> IO a
1440 dieWith :: Int -> String -> IO a
1443 prog <- getProgramName
1444 hPutStrLn stderr (prog ++ ": " ++ s)
1445 exitWith (ExitFailure ec)
1447 dieOrForceAll :: Force -> String -> IO ()
1448 dieOrForceAll ForceAll s = ignoreError s
1449 dieOrForceAll _other s = dieForcible s
1451 ignoreError :: String -> IO ()
1452 ignoreError s = reportError (s ++ " (ignoring)")
1454 reportError :: String -> IO ()
1455 reportError s = do hFlush stdout; hPutStrLn stderr s
1457 dieForcible :: String -> IO ()
1458 dieForcible s = die (s ++ " (use --force to override)")
1460 my_head :: String -> [a] -> a
1461 my_head s [] = error s
1462 my_head _ (x : _) = x
1464 -----------------------------------------
1465 -- Cut and pasted from ghc/compiler/main/SysTools
1467 #if defined(mingw32_HOST_OS)
1468 subst :: Char -> Char -> String -> String
1469 subst a b ls = map (\ x -> if x == a then b else x) ls
1471 unDosifyPath :: FilePath -> FilePath
1472 unDosifyPath xs = subst '\\' '/' xs
1474 getLibDir :: IO (Maybe String)
1475 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1477 -- (getExecDir cmd) returns the directory in which the current
1478 -- executable, which should be called 'cmd', is running
1479 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1480 -- you'll get "/a/b/c" back as the result
1481 getExecDir :: String -> IO (Maybe String)
1483 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1484 where initN n = reverse . drop n . reverse
1485 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1487 getExecPath :: IO (Maybe String)
1489 allocaArray len $ \buf -> do
1490 ret <- getModuleFileName nullPtr buf len
1491 if ret == 0 then return Nothing
1492 else liftM Just $ peekCString buf
1493 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1495 foreign import stdcall unsafe "GetModuleFileNameA"
1496 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1499 getLibDir :: IO (Maybe String)
1500 getLibDir = return Nothing
1503 -----------------------------------------
1504 -- Adapted from ghc/compiler/utils/Panic
1506 installSignalHandlers :: IO ()
1507 installSignalHandlers = do
1508 threadid <- myThreadId
1510 interrupt = Exception.throwTo threadid
1511 (Exception.ErrorCall "interrupted")
1513 #if !defined(mingw32_HOST_OS)
1514 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1515 _ <- installHandler sigINT (Catch interrupt) Nothing
1517 #elif __GLASGOW_HASKELL__ >= 603
1518 -- GHC 6.3+ has support for console events on Windows
1519 -- NOTE: running GHCi under a bash shell for some reason requires
1520 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1521 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1522 -- why --SDM 17/12/2004
1523 let sig_handler ControlC = interrupt
1524 sig_handler Break = interrupt
1525 sig_handler _ = return ()
1527 _ <- installHandler (Catch sig_handler)
1530 return () -- nothing
1533 #if __GLASGOW_HASKELL__ <= 604
1534 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1535 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1538 #if mingw32_HOST_OS || mingw32_TARGET_OS
1539 throwIOIO :: Exception.IOException -> IO a
1540 throwIOIO = Exception.throwIO
1542 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1543 catchIO = Exception.catch
1546 catchError :: IO a -> (String -> IO a) -> IO a
1547 catchError io handler = io `Exception.catch` handler'
1548 where handler' (Exception.ErrorCall err) = handler err
1551 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1552 -- to use text files here, rather than binary files.
1553 writeFileAtomic :: FilePath -> String -> IO ()
1554 writeFileAtomic targetFile content = do
1555 (newFile, newHandle) <- openNewFile targetDir template
1556 do hPutStr newHandle content
1558 #if mingw32_HOST_OS || mingw32_TARGET_OS
1559 renameFile newFile targetFile
1560 -- If the targetFile exists then renameFile will fail
1561 `catchIO` \err -> do
1562 exists <- doesFileExist targetFile
1564 then do removeFile targetFile
1565 -- Big fat hairy race condition
1566 renameFile newFile targetFile
1567 -- If the removeFile succeeds and the renameFile fails
1568 -- then we've lost the atomic property.
1571 renameFile newFile targetFile
1573 `Exception.onException` do hClose newHandle
1576 template = targetName <.> "tmp"
1577 targetDir | null targetDir_ = "."
1578 | otherwise = targetDir_
1579 --TODO: remove this when takeDirectory/splitFileName is fixed
1580 -- to always return a valid dir
1581 (targetDir_,targetName) = splitFileName targetFile
1583 -- Ugh, this is a copy/paste of code from the base library, but
1584 -- if uses 666 rather than 600 for the permissions.
1585 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1586 openNewFile dir template = do
1590 -- We split off the last extension, so we can use .foo.ext files
1591 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1592 -- below filepath in the hierarchy here.
1594 case break (== '.') $ reverse template of
1595 -- First case: template contains no '.'s. Just re-reverse it.
1596 (rev_suffix, "") -> (reverse rev_suffix, "")
1597 -- Second case: template contains at least one '.'. Strip the
1598 -- dot from the prefix and prepend it to the suffix (if we don't
1599 -- do this, the unique number will get added after the '.' and
1600 -- thus be part of the extension, which is wrong.)
1601 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1602 -- Otherwise, something is wrong, because (break (== '.')) should
1603 -- always return a pair with either the empty string or a string
1604 -- beginning with '.' as the second component.
1605 _ -> error "bug in System.IO.openTempFile"
1607 oflags = rw_flags .|. o_EXCL
1609 #if __GLASGOW_HASKELL__ < 611
1610 withFilePath = withCString
1614 fd <- withFilePath filepath $ \ f ->
1615 c_open f oflags 0o666
1620 then findTempName (x+1)
1621 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1623 -- XXX We want to tell fdToHandle what the filepath is,
1624 -- as any exceptions etc will only be able to report the
1627 #if __GLASGOW_HASKELL__ >= 609
1630 fdToHandle (fromIntegral fd)
1632 `Exception.onException` c_close fd
1633 return (filepath, h)
1635 filename = prefix ++ show x ++ suffix
1636 filepath = dir `combine` filename
1638 -- XXX Copied from GHC.Handle
1639 std_flags, output_flags, rw_flags :: CInt
1640 std_flags = o_NONBLOCK .|. o_NOCTTY
1641 output_flags = std_flags .|. o_CREAT
1642 rw_flags = output_flags .|. o_RDWR
1644 -- | The function splits the given string to substrings
1645 -- using 'isSearchPathSeparator'.
1646 parseSearchPath :: String -> [FilePath]
1647 parseSearchPath path = split path
1649 split :: String -> [String]
1653 _:rest -> chunk : split rest
1657 #ifdef mingw32_HOST_OS
1658 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1662 (chunk', rest') = break isSearchPathSeparator s
1664 readUTF8File :: FilePath -> IO String
1665 readUTF8File file = do
1666 h <- openFile file ReadMode
1667 #if __GLASGOW_HASKELL__ >= 612
1668 -- fix the encoding to UTF-8