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
55 #if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS)
56 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
61 #if __GLASGOW_HASKELL__ < 612
62 import System.Posix.Internals
63 #if __GLASGOW_HASKELL__ >= 611
64 import GHC.IO.Handle.FD (fdToHandle)
66 import GHC.Handle (fdToHandle)
70 #ifdef mingw32_HOST_OS
71 import GHC.ConsoleHandler
73 import System.Posix hiding (fdToHandle)
76 import IO ( isPermissionError )
79 import System.Process(runInteractiveCommand)
80 import qualified System.Info(os)
83 #if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
84 import System.Console.Terminfo as Terminfo
87 -- -----------------------------------------------------------------------------
94 case getOpt Permute (flags ++ deprecFlags) args of
95 (cli,_,[]) | FlagHelp `elem` cli -> do
96 prog <- getProgramName
97 bye (usageInfo (usageHeader prog) flags)
98 (cli,_,[]) | FlagVersion `elem` cli ->
101 case getVerbosity Normal cli of
102 Right v -> runit v cli nonopts
105 prog <- getProgramName
106 die (concat errors ++ usageInfo (usageHeader prog) flags)
108 -- -----------------------------------------------------------------------------
109 -- Command-line syntax
116 | FlagConfig FilePath
117 | FlagGlobalConfig FilePath
125 | FlagVerbosity (Maybe String)
128 flags :: [OptDescr Flag]
130 Option [] ["user"] (NoArg FlagUser)
131 "use the current user's package database",
132 Option [] ["global"] (NoArg FlagGlobal)
133 "use the global package database",
134 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
135 "use the specified package config file",
136 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
137 "location of the global package config",
138 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
139 "never read the user package database",
140 Option [] ["force"] (NoArg FlagForce)
141 "ignore missing dependencies, directories, and libraries",
142 Option [] ["force-files"] (NoArg FlagForceFiles)
143 "ignore missing directories and libraries only",
144 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
145 "automatically build libs for GHCi (with register)",
146 Option ['?'] ["help"] (NoArg FlagHelp)
147 "display this help and exit",
148 Option ['V'] ["version"] (NoArg FlagVersion)
149 "output version information and exit",
150 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
151 "print output in easy-to-parse format for some commands",
152 Option [] ["names-only"] (NoArg FlagNamesOnly)
153 "only print package names, not versions; can only be used with list --simple-output",
154 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
155 "ignore case for substring matching",
156 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
157 "verbosity level (0-2, default 1)"
160 data Verbosity = Silent | Normal | Verbose
161 deriving (Show, Eq, Ord)
163 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
164 getVerbosity v [] = Right v
165 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
166 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
167 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
168 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
169 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
170 getVerbosity v (_ : fs) = getVerbosity v fs
172 deprecFlags :: [OptDescr Flag]
174 -- put deprecated flags here
177 ourCopyright :: String
178 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
180 usageHeader :: String -> String
181 usageHeader prog = substProg prog $
183 " $p init {path}\n" ++
184 " Create and initialise a package database at the location {path}.\n" ++
185 " Packages can be registered in the new database using the register\n" ++
186 " command with --package-conf={path}. To use the new database with GHC,\n" ++
187 " use GHC's -package-conf flag.\n" ++
189 " $p register {filename | -}\n" ++
190 " Register the package using the specified installed package\n" ++
191 " description. The syntax for the latter is given in the $p\n" ++
192 " documentation. The input file should be encoded in UTF-8.\n" ++
194 " $p update {filename | -}\n" ++
195 " Register the package, overwriting any other package with the\n" ++
196 " same name. The input file should be encoded in UTF-8.\n" ++
198 " $p unregister {pkg-id}\n" ++
199 " Unregister the specified package.\n" ++
201 " $p expose {pkg-id}\n" ++
202 " Expose the specified package.\n" ++
204 " $p hide {pkg-id}\n" ++
205 " Hide the specified package.\n" ++
207 " $p list [pkg]\n" ++
208 " List registered packages in the global database, and also the\n" ++
209 " user database if --user is given. If a package name is given\n" ++
210 " all the registered versions will be listed in ascending order.\n" ++
211 " Accepts the --simple-output flag.\n" ++
214 " Generate a graph of the package dependencies in a form suitable\n" ++
215 " for input for the graphviz tools. For example, to generate a PDF" ++
216 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
218 " $p find-module {module}\n" ++
219 " List registered packages exposing module {module} in the global\n" ++
220 " database, and also the user database if --user is given.\n" ++
221 " All the registered versions will be listed in ascending order.\n" ++
222 " Accepts the --simple-output flag.\n" ++
224 " $p latest {pkg-id}\n" ++
225 " Prints the highest registered version of a package.\n" ++
228 " Check the consistency of package depenencies and list broken packages.\n" ++
229 " Accepts the --simple-output flag.\n" ++
231 " $p describe {pkg}\n" ++
232 " Give the registered description for the specified package. The\n" ++
233 " description is returned in precisely the syntax required by $p\n" ++
236 " $p field {pkg} {field}\n" ++
237 " Extract the specified field of the package description for the\n" ++
238 " specified package. Accepts comma-separated multiple fields.\n" ++
241 " Dump the registered description for every package. This is like\n" ++
242 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
243 " by tools that parse the results, rather than humans. The output is\n" ++
244 " always encoded in UTF-8, regardless of the current locale.\n" ++
247 " Regenerate the package database cache. This command should only be\n" ++
248 " necessary if you added a package to the database by dropping a file\n" ++
249 " into the database directory manually. By default, the global DB\n" ++
250 " is recached; to recache a different DB use --user or --package-conf\n" ++
251 " as appropriate.\n" ++
253 " Substring matching is supported for {module} in find-module and\n" ++
254 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
255 " open substring ends (prefix*, *suffix, *infix*).\n" ++
257 " When asked to modify a database (register, unregister, update,\n"++
258 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
259 " default. Specifying --user causes it to act on the user database,\n"++
260 " or --package-conf can be used to act on another database\n"++
261 " entirely. When multiple of these options are given, the rightmost\n"++
262 " one is used as the database to act upon.\n"++
264 " Commands that query the package database (list, tree, latest, describe,\n"++
265 " field) operate on the list of databases specified by the flags\n"++
266 " --user, --global, and --package-conf. If none of these flags are\n"++
267 " given, the default is --global --user.\n"++
269 " The following optional flags are also accepted:\n"
271 substProg :: String -> String -> String
273 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
274 substProg prog (c:xs) = c : substProg prog xs
276 -- -----------------------------------------------------------------------------
279 data Force = NoForce | ForceFiles | ForceAll | CannotForce
282 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
284 runit :: Verbosity -> [Flag] -> [String] -> IO ()
285 runit verbosity cli nonopts = do
286 installSignalHandlers -- catch ^C and clean up
287 prog <- getProgramName
290 | FlagForce `elem` cli = ForceAll
291 | FlagForceFiles `elem` cli = ForceFiles
292 | otherwise = NoForce
293 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
294 splitFields fields = unfoldr splitComma (',':fields)
295 where splitComma "" = Nothing
296 splitComma fs = Just $ break (==',') (tail fs)
298 substringCheck :: String -> Maybe (String -> Bool)
299 substringCheck "" = Nothing
300 substringCheck "*" = Just (const True)
301 substringCheck [_] = Nothing
302 substringCheck (h:t) =
303 case (h, init t, last t) of
304 ('*',s,'*') -> Just (isInfixOf (f s) . f)
305 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
306 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
308 where f | FlagIgnoreCase `elem` cli = map toLower
311 glob x | System.Info.os=="mingw32" = do
312 -- glob echoes its argument, after win32 filename globbing
313 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
314 txt <- hGetContents o
316 glob x | otherwise = return [x]
319 -- first, parse the command
322 -- dummy command to demonstrate usage and permit testing
323 -- without messing things up; use glob to selectively enable
324 -- windows filename globbing for file parameters
325 -- register, update, FlagGlobalConfig, FlagConfig; others?
326 ["glob", filename] -> do
328 glob filename >>= print
330 ["init", filename] ->
331 initPackageDB filename verbosity cli
332 ["register", filename] ->
333 registerPackage filename verbosity cli auto_ghci_libs False force
334 ["update", filename] ->
335 registerPackage filename verbosity cli auto_ghci_libs True force
336 ["unregister", pkgid_str] -> do
337 pkgid <- readGlobPkgId pkgid_str
338 unregisterPackage pkgid verbosity cli force
339 ["expose", pkgid_str] -> do
340 pkgid <- readGlobPkgId pkgid_str
341 exposePackage pkgid verbosity cli force
342 ["hide", pkgid_str] -> do
343 pkgid <- readGlobPkgId pkgid_str
344 hidePackage pkgid verbosity cli force
346 listPackages verbosity cli Nothing Nothing
347 ["list", pkgid_str] ->
348 case substringCheck pkgid_str of
349 Nothing -> do pkgid <- readGlobPkgId pkgid_str
350 listPackages verbosity cli (Just (Id pkgid)) Nothing
351 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
353 showPackageDot verbosity cli
354 ["find-module", moduleName] -> do
355 let match = maybe (==moduleName) id (substringCheck moduleName)
356 listPackages verbosity cli Nothing (Just match)
357 ["latest", pkgid_str] -> do
358 pkgid <- readGlobPkgId pkgid_str
359 latestPackage verbosity cli pkgid
360 ["describe", pkgid_str] ->
361 case substringCheck pkgid_str of
362 Nothing -> do pkgid <- readGlobPkgId pkgid_str
363 describePackage verbosity cli (Id pkgid)
364 Just m -> describePackage verbosity cli (Substring pkgid_str m)
365 ["field", pkgid_str, fields] ->
366 case substringCheck pkgid_str of
367 Nothing -> do pkgid <- readGlobPkgId pkgid_str
368 describeField verbosity cli (Id pkgid)
370 Just m -> describeField verbosity cli (Substring pkgid_str m)
373 checkConsistency verbosity cli
376 dumpPackages verbosity cli
379 recache verbosity cli
382 die ("missing command\n" ++
383 usageInfo (usageHeader prog) flags)
385 die ("command-line syntax error\n" ++
386 usageInfo (usageHeader prog) flags)
388 parseCheck :: ReadP a a -> String -> String -> IO a
389 parseCheck parser str what =
390 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
392 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
394 readGlobPkgId :: String -> IO PackageIdentifier
395 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
397 parseGlobPackageId :: ReadP r PackageIdentifier
403 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
405 -- globVersion means "all versions"
406 globVersion :: Version
407 globVersion = Version{ versionBranch=[], versionTags=["*"] }
409 -- -----------------------------------------------------------------------------
412 -- Some commands operate on a single database:
413 -- register, unregister, expose, hide
414 -- however these commands also check the union of the available databases
415 -- in order to check consistency. For example, register will check that
416 -- dependencies exist before registering a package.
418 -- Some commands operate on multiple databases, with overlapping semantics:
419 -- list, describe, field
422 = PackageDB { location :: FilePath,
423 packages :: [InstalledPackageInfo] }
425 type PackageDBStack = [PackageDB]
426 -- A stack of package databases. Convention: head is the topmost
429 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
430 allPackagesInStack = concatMap packages
432 getPkgDatabases :: Verbosity
433 -> Bool -- we are modifying, not reading
434 -> Bool -- read caches, if available
436 -> IO (PackageDBStack,
437 -- the real package DB stack: [global,user] ++
438 -- DBs specified on the command line with -f.
440 -- which one to modify, if any
442 -- the package DBs specified on the command
443 -- line, or [global,user] otherwise. This
444 -- is used as the list of package DBs for
445 -- commands that just read the DB, such as 'list'.
447 getPkgDatabases verbosity modify use_cache my_flags = do
448 -- first we determine the location of the global package config. On Windows,
449 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
450 -- location is passed to the binary using the --global-config flag by the
452 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
454 case [ f | FlagGlobalConfig f <- my_flags ] of
455 [] -> do mb_dir <- getLibDir
457 Nothing -> die err_msg
459 r <- lookForPackageDBIn dir
461 Nothing -> die ("Can't find package database in " ++ dir)
462 Just path -> return path
463 fs -> return (last fs)
465 let no_user_db = FlagNoUserDb `elem` my_flags
467 -- get the location of the user package database, and create it if necessary
468 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
469 e_appdir <- try $ getAppUserDataDirectory "ghc"
472 if no_user_db then return Nothing else
474 Left _ -> return Nothing
476 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
477 dir = appdir </> subdir
478 r <- lookForPackageDBIn dir
480 Nothing -> return (Just (dir </> "package.conf.d", False))
481 Just f -> return (Just (f, True))
483 -- If the user database doesn't exist, and this command isn't a
484 -- "modify" command, then we won't attempt to create or use it.
486 | Just (user_conf,user_exists) <- mb_user_conf,
487 modify || user_exists = [user_conf, global_conf]
488 | otherwise = [global_conf]
490 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
493 Left _ -> sys_databases
495 | last cs == "" -> init cs ++ sys_databases
497 where cs = parseSearchPath path
499 -- The "global" database is always the one at the bottom of the stack.
500 -- This is the database we modify by default.
501 virt_global_conf = last env_stack
503 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
504 where is_db_flag FlagUser
505 | Just (user_conf, _user_exists) <- mb_user_conf
507 is_db_flag FlagGlobal = Just virt_global_conf
508 is_db_flag (FlagConfig f) = Just f
509 is_db_flag _ = Nothing
511 let flag_db_names | null db_flags = env_stack
512 | otherwise = reverse (nub db_flags)
514 -- For a "modify" command, treat all the databases as
515 -- a stack, where we are modifying the top one, but it
516 -- can refer to packages in databases further down the
519 -- -f flags on the command line add to the database
520 -- stack, unless any of them are present in the stack
522 let final_stack = filter (`notElem` env_stack)
523 [ f | FlagConfig f <- reverse my_flags ]
526 -- the database we actually modify is the one mentioned
527 -- rightmost on the command-line.
529 | not modify = Nothing
530 | null db_flags = Just virt_global_conf
531 | otherwise = Just (last db_flags)
533 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
535 let flag_db_stack = [ db | db_name <- flag_db_names,
536 db <- db_stack, location db == db_name ]
538 return (db_stack, to_modify, flag_db_stack)
541 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
542 lookForPackageDBIn dir = do
543 let path_dir = dir </> "package.conf.d"
544 exists_dir <- doesDirectoryExist path_dir
545 if exists_dir then return (Just path_dir) else do
546 let path_file = dir </> "package.conf"
547 exists_file <- doesFileExist path_file
548 if exists_file then return (Just path_file) else return Nothing
550 readParseDatabase :: Verbosity
551 -> Maybe (FilePath,Bool)
556 readParseDatabase verbosity mb_user_conf use_cache path
557 -- the user database (only) is allowed to be non-existent
558 | Just (user_conf,False) <- mb_user_conf, path == user_conf
559 = return PackageDB { location = path, packages = [] }
561 = do e <- try $ getDirectoryContents path
564 pkgs <- parseMultiPackageConf verbosity path
565 return PackageDB{ location = path, packages = pkgs }
567 | not use_cache -> ignore_cache
569 let cache = path </> cachefilename
570 tdir <- getModificationTime path
571 e_tcache <- try $ getModificationTime cache
574 when (verbosity > Normal) $
575 putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
578 | tcache >= tdir -> do
579 when (verbosity > Normal) $
580 putStrLn ("using cache: " ++ cache)
581 pkgs <- myReadBinPackageDB cache
582 let pkgs' = map convertPackageInfoIn pkgs
583 return PackageDB { location = path, packages = pkgs' }
585 when (verbosity >= Normal) $ do
586 putStrLn ("WARNING: cache is out of date: " ++ cache)
587 putStrLn " use 'ghc-pkg recache' to fix."
591 let confs = filter (".conf" `isSuffixOf`) fs
592 pkgs <- mapM (parseSingletonPackageConf verbosity) $
594 return PackageDB { location = path, packages = pkgs }
596 -- read the package.cache file strictly, to work around a problem with
597 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
598 -- after it has been completely read, leading to a sharing violation
600 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
601 myReadBinPackageDB filepath = do
602 h <- openBinaryFile filepath ReadMode
604 b <- B.hGet h (fromIntegral sz)
606 return $ Bin.runGet Bin.get b
608 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
609 parseMultiPackageConf verbosity file = do
610 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
611 str <- readUTF8File file
612 let pkgs = map convertPackageInfoIn $ read str
613 Exception.evaluate pkgs
615 die ("error while parsing " ++ file ++ ": " ++ show e)
617 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
618 parseSingletonPackageConf verbosity file = do
619 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
620 readUTF8File file >>= parsePackageInfo
622 cachefilename :: FilePath
623 cachefilename = "package.cache"
625 -- -----------------------------------------------------------------------------
626 -- Creating a new package DB
628 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
629 initPackageDB filename verbosity _flags = do
630 let eexist = die ("cannot create: " ++ filename ++ " already exists")
631 b1 <- doesFileExist filename
633 b2 <- doesDirectoryExist filename
635 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
637 -- -----------------------------------------------------------------------------
640 registerPackage :: FilePath
643 -> Bool -- auto_ghci_libs
647 registerPackage input verbosity my_flags auto_ghci_libs update force = do
648 (db_stack, Just to_modify, _flag_dbs) <-
649 getPkgDatabases verbosity True True my_flags
652 db_to_operate_on = my_head "register" $
653 filter ((== to_modify).location) db_stack
658 when (verbosity >= Normal) $
659 putStr "Reading package info from stdin ... "
660 #if __GLASGOW_HASKELL__ >= 612
661 -- fix the encoding to UTF-8, since this is an interchange format
662 hSetEncoding stdin utf8
666 when (verbosity >= Normal) $
667 putStr ("Reading package info from " ++ show f ++ " ... ")
670 expanded <- expandEnvVars s force
672 pkg <- parsePackageInfo expanded
673 when (verbosity >= Normal) $
676 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
677 -- truncate the stack for validation, because we don't allow
678 -- packages lower in the stack to refer to those higher up.
679 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
681 removes = [ RemovePackage p
682 | p <- packages db_to_operate_on,
683 sourcePackageId p == sourcePackageId pkg ]
685 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
689 -> IO InstalledPackageInfo
690 parsePackageInfo str =
691 case parseInstalledPackageInfo str of
692 ParseOk _warns ok -> return ok
693 ParseFailed err -> case locatedErrorMsg err of
694 (Nothing, s) -> die s
695 (Just l, s) -> die (show l ++ ": " ++ s)
697 -- -----------------------------------------------------------------------------
698 -- Making changes to a package database
700 data DBOp = RemovePackage InstalledPackageInfo
701 | AddPackage InstalledPackageInfo
702 | ModifyPackage InstalledPackageInfo
704 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
705 changeDB verbosity cmds db = do
706 let db' = updateInternalDB db cmds
707 isfile <- doesFileExist (location db)
709 then writeNewConfig verbosity (location db') (packages db')
711 createDirectoryIfMissing True (location db)
712 changeDBDir verbosity cmds db'
714 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
715 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
717 do_cmd pkgs (RemovePackage p) =
718 filter ((/= installedPackageId p) . installedPackageId) pkgs
719 do_cmd pkgs (AddPackage p) = p : pkgs
720 do_cmd pkgs (ModifyPackage p) =
721 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
724 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
725 changeDBDir verbosity cmds db = do
727 updateDBCache verbosity db
729 do_cmd (RemovePackage p) = do
730 let file = location db </> display (installedPackageId p) <.> "conf"
731 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
733 do_cmd (AddPackage p) = do
734 let file = location db </> display (installedPackageId p) <.> "conf"
735 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
736 writeFileUtf8Atomic file (showInstalledPackageInfo p)
737 do_cmd (ModifyPackage p) =
738 do_cmd (AddPackage p)
740 updateDBCache :: Verbosity -> PackageDB -> IO ()
741 updateDBCache verbosity db = do
742 let filename = location db </> cachefilename
743 when (verbosity > Normal) $
744 putStrLn ("writing cache " ++ filename)
745 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
747 if isPermissionError e
748 then die (filename ++ ": you don't have permission to modify this file")
751 -- -----------------------------------------------------------------------------
752 -- Exposing, Hiding, Unregistering are all similar
754 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
755 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
757 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
758 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
760 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
761 unregisterPackage = modifyPackage RemovePackage
764 :: (InstalledPackageInfo -> DBOp)
770 modifyPackage fn pkgid verbosity my_flags force = do
771 (db_stack, Just _to_modify, _flag_dbs) <-
772 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
774 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
776 db_name = location db
779 pids = map sourcePackageId ps
781 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
782 new_db = updateInternalDB db cmds
784 old_broken = brokenPackages (allPackagesInStack db_stack)
785 rest_of_stack = filter ((/= db_name) . location) db_stack
786 new_stack = new_db : rest_of_stack
787 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
788 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
790 when (not (null newly_broken)) $
791 dieOrForceAll force ("unregistering " ++ display pkgid ++
792 " would break the following packages: "
793 ++ unwords (map display newly_broken))
795 changeDB verbosity cmds db
797 recache :: Verbosity -> [Flag] -> IO ()
798 recache verbosity my_flags = do
799 (db_stack, Just to_modify, _flag_dbs) <-
800 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
802 db_to_operate_on = my_head "recache" $
803 filter ((== to_modify).location) db_stack
805 changeDB verbosity [] db_to_operate_on
807 -- -----------------------------------------------------------------------------
810 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
811 -> Maybe (String->Bool)
813 listPackages verbosity my_flags mPackageName mModuleName = do
814 let simple_output = FlagSimpleOutput `elem` my_flags
815 (db_stack, _, flag_db_stack) <-
816 getPkgDatabases verbosity False True{-use cache-} my_flags
818 let db_stack_filtered -- if a package is given, filter out all other packages
819 | Just this <- mPackageName =
820 [ db{ packages = filter (this `matchesPkg`) (packages db) }
821 | db <- flag_db_stack ]
822 | Just match <- mModuleName = -- packages which expose mModuleName
823 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
824 | db <- flag_db_stack ]
825 | otherwise = flag_db_stack
828 = [ db{ packages = sort_pkgs (packages db) }
829 | db <- db_stack_filtered ]
830 where sort_pkgs = sortBy cmpPkgIds
831 cmpPkgIds pkg1 pkg2 =
832 case pkgName p1 `compare` pkgName p2 of
835 EQ -> pkgVersion p1 `compare` pkgVersion p2
836 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
838 stack = reverse db_stack_sorted
840 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
842 pkg_map = allPackagesInStack db_stack
843 broken = map sourcePackageId (brokenPackages pkg_map)
845 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
846 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
848 pp_pkgs = map pp_pkg pkg_confs
850 | sourcePackageId p `elem` broken = printf "{%s}" doc
852 | otherwise = printf "(%s)" doc
853 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
856 InstalledPackageId ipid = installedPackageId p
857 pkg = display (sourcePackageId p)
859 show_simple = simplePackageList my_flags . allPackagesInStack
861 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
862 prog <- getProgramName
863 putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
865 if simple_output then show_simple stack else do
867 #if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
868 mapM_ show_normal stack
871 show_colour withF db =
872 mconcat $ map (<#> termText "\n") $
873 (termText (location db) :
874 map (termText " " <#>) (map pp_pkg (packages db)))
877 | sourcePackageId p `elem` broken = withF Red doc
879 | otherwise = withF Blue doc
880 where doc | verbosity >= Verbose
881 = termText (printf "%s (%s)" pkg ipid)
885 InstalledPackageId ipid = installedPackageId p
886 pkg = display (sourcePackageId p)
888 is_tty <- hIsTerminalDevice stdout
890 then mapM_ show_normal stack
891 else do tty <- Terminfo.setupTermFromEnv
892 case Terminfo.getCapability tty withForegroundColor of
893 Nothing -> mapM_ show_normal stack
894 Just w -> runTermOutput tty $ mconcat $
895 map (show_colour w) stack
898 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
899 simplePackageList my_flags pkgs = do
900 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
902 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
903 when (not (null pkgs)) $
904 hPutStrLn stdout $ concat $ intersperse " " strs
906 showPackageDot :: Verbosity -> [Flag] -> IO ()
907 showPackageDot verbosity myflags = do
908 (_, _, flag_db_stack) <-
909 getPkgDatabases verbosity False True{-use cache-} myflags
911 let all_pkgs = allPackagesInStack flag_db_stack
912 ipix = PackageIndex.fromList all_pkgs
915 let quote s = '"':s ++ "\""
916 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
918 let from = display (sourcePackageId p),
920 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
921 let to = display (sourcePackageId dep)
925 -- -----------------------------------------------------------------------------
926 -- Prints the highest (hidden or exposed) version of a package
928 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
929 latestPackage verbosity my_flags pkgid = do
930 (_, _, flag_db_stack) <-
931 getPkgDatabases verbosity False True{-use cache-} my_flags
933 ps <- findPackages flag_db_stack (Id pkgid)
934 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
936 show_pkg [] = die "no matches"
937 show_pkg pids = hPutStrLn stdout (display (last pids))
939 -- -----------------------------------------------------------------------------
942 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
943 describePackage verbosity my_flags pkgarg = do
944 (_, _, flag_db_stack) <-
945 getPkgDatabases verbosity False True{-use cache-} my_flags
946 ps <- findPackages flag_db_stack pkgarg
949 dumpPackages :: Verbosity -> [Flag] -> IO ()
950 dumpPackages verbosity my_flags = do
951 (_, _, flag_db_stack) <-
952 getPkgDatabases verbosity False True{-use cache-} my_flags
953 doDump (allPackagesInStack flag_db_stack)
955 doDump :: [InstalledPackageInfo] -> IO ()
957 #if __GLASGOW_HASKELL__ >= 612
958 -- fix the encoding to UTF-8, since this is an interchange format
959 hSetEncoding stdout utf8
961 mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
963 -- PackageId is can have globVersion for the version
964 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
965 findPackages db_stack pkgarg
966 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
968 findPackagesByDB :: PackageDBStack -> PackageArg
969 -> IO [(PackageDB, [InstalledPackageInfo])]
970 findPackagesByDB db_stack pkgarg
971 = case [ (db, matched)
973 let matched = filter (pkgarg `matchesPkg`) (packages db),
974 not (null matched) ] of
975 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
978 pkg_msg (Id pkgid) = display pkgid
979 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
981 matches :: PackageIdentifier -> PackageIdentifier -> Bool
983 = (pkgName pid == pkgName pid')
984 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
986 realVersion :: PackageIdentifier -> Bool
987 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
988 -- when versionBranch == [], this is a glob
990 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
991 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
992 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
994 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
995 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
997 -- -----------------------------------------------------------------------------
1000 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
1001 describeField verbosity my_flags pkgarg fields = do
1002 (_, _, flag_db_stack) <-
1003 getPkgDatabases verbosity False True{-use cache-} my_flags
1004 fns <- toFields fields
1005 ps <- findPackages flag_db_stack pkgarg
1006 let top_dir = takeDirectory (location (last flag_db_stack))
1007 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
1008 where toFields [] = return []
1009 toFields (f:fs) = case toField f of
1010 Nothing -> die ("unknown field: " ++ f)
1011 Just fn -> do fns <- toFields fs
1013 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1015 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1016 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1017 -- with the current topdir (obtained from the -B option).
1018 mungePackagePaths top_dir ps = map munge_pkg ps
1020 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
1021 includeDirs = munge_paths (includeDirs p),
1022 libraryDirs = munge_paths (libraryDirs p),
1023 frameworkDirs = munge_paths (frameworkDirs p),
1024 haddockInterfaces = munge_paths (haddockInterfaces p),
1025 haddockHTMLs = munge_paths (haddockHTMLs p)
1028 munge_paths = map munge_path
1031 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1032 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1035 toHttpPath p = "file:///" ++ p
1037 maybePrefixMatch :: String -> String -> Maybe String
1038 maybePrefixMatch [] rest = Just rest
1039 maybePrefixMatch (_:_) [] = Nothing
1040 maybePrefixMatch (p:pat) (r:rest)
1041 | p == r = maybePrefixMatch pat rest
1042 | otherwise = Nothing
1044 toField :: String -> Maybe (InstalledPackageInfo -> String)
1045 -- backwards compatibility:
1046 toField "import_dirs" = Just $ strList . importDirs
1047 toField "source_dirs" = Just $ strList . importDirs
1048 toField "library_dirs" = Just $ strList . libraryDirs
1049 toField "hs_libraries" = Just $ strList . hsLibraries
1050 toField "extra_libraries" = Just $ strList . extraLibraries
1051 toField "include_dirs" = Just $ strList . includeDirs
1052 toField "c_includes" = Just $ strList . includes
1053 toField "package_deps" = Just $ strList . map display. depends
1054 toField "extra_cc_opts" = Just $ strList . ccOptions
1055 toField "extra_ld_opts" = Just $ strList . ldOptions
1056 toField "framework_dirs" = Just $ strList . frameworkDirs
1057 toField "extra_frameworks"= Just $ strList . frameworks
1058 toField s = showInstalledPackageInfoField s
1060 strList :: [String] -> String
1064 -- -----------------------------------------------------------------------------
1065 -- Check: Check consistency of installed packages
1067 checkConsistency :: Verbosity -> [Flag] -> IO ()
1068 checkConsistency verbosity my_flags = do
1069 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1070 -- check behaves like modify for the purposes of deciding which
1071 -- databases to use, because ordering is important.
1073 let simple_output = FlagSimpleOutput `elem` my_flags
1075 let pkgs = allPackagesInStack db_stack
1078 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
1082 when (not simple_output) $ do
1083 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1084 _ <- reportValidateErrors es " " Nothing
1088 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1090 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1091 where not_in p = sourcePackageId p `notElem` all_ps
1092 all_ps = map sourcePackageId pkgs1
1094 let not_broken_pkgs = filterOut broken_pkgs pkgs
1095 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1096 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1098 when (not (null all_broken_pkgs)) $ do
1100 then simplePackageList my_flags all_broken_pkgs
1102 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1103 "listed above, or because they depend on a broken package.")
1104 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1106 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1109 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1110 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1111 closure pkgs db_stack = go pkgs db_stack
1113 go avail not_avail =
1114 case partition (depsAvailable avail) not_avail of
1115 ([], not_avail') -> (avail, not_avail')
1116 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1118 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1120 depsAvailable pkgs_ok pkg = null dangling
1121 where dangling = filter (`notElem` pids) (depends pkg)
1122 pids = map installedPackageId pkgs_ok
1124 -- we want mutually recursive groups of package to show up
1125 -- as broken. (#1750)
1127 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1128 brokenPackages pkgs = snd (closure [] pkgs)
1130 -- -----------------------------------------------------------------------------
1131 -- Manipulating package.conf files
1133 type InstalledPackageInfoString = InstalledPackageInfo_ String
1135 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1136 convertPackageInfoOut
1137 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1138 hiddenModules = h })) =
1139 pkgconf{ exposedModules = map display e,
1140 hiddenModules = map display h }
1142 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1143 convertPackageInfoIn
1144 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1145 hiddenModules = h })) =
1146 pkgconf{ exposedModules = map convert e,
1147 hiddenModules = map convert h }
1148 where convert = fromJust . simpleParse
1150 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1151 writeNewConfig verbosity filename ipis = do
1152 when (verbosity >= Normal) $
1153 hPutStr stdout "Writing new package config file... "
1154 createDirectoryIfMissing True $ takeDirectory filename
1155 let shown = concat $ intersperse ",\n "
1156 $ map (show . convertPackageInfoOut) ipis
1157 fileContents = "[" ++ shown ++ "\n]"
1158 writeFileUtf8Atomic filename fileContents
1160 if isPermissionError e
1161 then die (filename ++ ": you don't have permission to modify this file")
1163 when (verbosity >= Normal) $
1164 hPutStrLn stdout "done."
1166 -----------------------------------------------------------------------------
1167 -- Sanity-check a new package config, and automatically build GHCi libs
1170 type ValidateError = (Force,String)
1172 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
1174 instance Monad Validate where
1175 return a = V $ return (a, [])
1177 (a, es) <- runValidate m
1178 (b, es') <- runValidate (k a)
1181 verror :: Force -> String -> Validate ()
1182 verror f s = V (return ((),[(f,s)]))
1184 liftIO :: IO a -> Validate a
1185 liftIO k = V (k >>= \a -> return (a,[]))
1187 -- returns False if we should die
1188 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
1189 reportValidateErrors es prefix mb_force = do
1190 oks <- mapM report es
1194 | Just force <- mb_force
1196 then do reportError (prefix ++ s ++ " (ignoring)")
1198 else if f < CannotForce
1199 then do reportError (prefix ++ s ++ " (use --force to override)")
1201 else do reportError err
1203 | otherwise = do reportError err
1208 validatePackageConfig :: InstalledPackageInfo
1210 -> Bool -- auto-ghc-libs
1211 -> Bool -- update, or check
1214 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1215 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1216 ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
1217 when (not ok) $ exitWith (ExitFailure 1)
1219 checkPackageConfig :: InstalledPackageInfo
1221 -> Bool -- auto-ghc-libs
1222 -> Bool -- update, or check
1224 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1225 checkInstalledPackageId pkg db_stack update
1227 checkDuplicates db_stack pkg update
1228 mapM_ (checkDep db_stack) (depends pkg)
1229 checkDuplicateDepends (depends pkg)
1230 mapM_ (checkDir "import-dirs") (importDirs pkg)
1231 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
1232 mapM_ (checkDir "include-dirs") (includeDirs pkg)
1234 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1235 -- ToDo: check these somehow?
1236 -- extra_libraries :: [String],
1237 -- c_includes :: [String],
1239 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1241 checkInstalledPackageId ipi db_stack update = do
1242 let ipid@(InstalledPackageId str) = installedPackageId ipi
1243 when (null str) $ verror CannotForce "missing id field"
1244 let dups = [ p | p <- allPackagesInStack db_stack,
1245 installedPackageId p == ipid ]
1246 when (not update && not (null dups)) $
1247 verror CannotForce $
1248 "package(s) with this id already exist: " ++
1249 unwords (map (display.packageId) dups)
1251 -- When the package name and version are put together, sometimes we can
1252 -- end up with a package id that cannot be parsed. This will lead to
1253 -- difficulties when the user wants to refer to the package later, so
1254 -- we check that the package id can be parsed properly here.
1255 checkPackageId :: InstalledPackageInfo -> Validate ()
1256 checkPackageId ipi =
1257 let str = display (sourcePackageId ipi) in
1258 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1260 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1261 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1263 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1264 checkDuplicates db_stack pkg update = do
1266 pkgid = sourcePackageId pkg
1267 pkgs = packages (head db_stack)
1269 -- Check whether this package id already exists in this DB
1271 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1272 verror CannotForce $
1273 "package " ++ display pkgid ++ " is already installed"
1276 uncasep = map toLower . display
1277 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1279 when (not update && not (null dups)) $ verror ForceAll $
1280 "Package names may be treated case-insensitively in the future.\n"++
1281 "Package " ++ display pkgid ++
1282 " overlaps with: " ++ unwords (map display dups)
1285 checkDir :: String -> String -> Validate ()
1286 checkDir thisfield d
1287 | "$topdir" `isPrefixOf` d = return ()
1288 | "$httptopdir" `isPrefixOf` d = return ()
1289 -- can't check these, because we don't know what $(http)topdir is
1291 there <- liftIO $ doesDirectoryExist d
1293 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1295 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1296 checkDep db_stack pkgid
1297 | pkgid `elem` pkgids = return ()
1298 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1299 ++ "\" doesn't exist")
1301 all_pkgs = allPackagesInStack db_stack
1302 pkgids = map installedPackageId all_pkgs
1304 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1305 checkDuplicateDepends deps
1306 | null dups = return ()
1307 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1308 unwords (map display dups))
1310 dups = [ p | (p:_:_) <- group (sort deps) ]
1312 checkHSLib :: [String] -> Bool -> String -> Validate ()
1313 checkHSLib dirs auto_ghci_libs lib = do
1314 let batch_lib_file = "lib" ++ lib ++ ".a"
1315 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1317 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1319 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1321 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1322 doesFileExistOnPath file path = go path
1323 where go [] = return Nothing
1324 go (p:ps) = do b <- doesFileExistIn file p
1325 if b then return (Just p) else go ps
1327 doesFileExistIn :: String -> String -> IO Bool
1328 doesFileExistIn lib d
1329 | "$topdir" `isPrefixOf` d = return True
1330 | "$httptopdir" `isPrefixOf` d = return True
1331 | otherwise = doesFileExist (d </> lib)
1333 checkModules :: InstalledPackageInfo -> Validate ()
1334 checkModules pkg = do
1335 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1337 findModule modl = do
1338 -- there's no .hi file for GHC.Prim
1339 if modl == fromString "GHC.Prim" then return () else do
1340 let file = toFilePath modl <.> "hi"
1341 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1342 when (isNothing m) $
1343 verror ForceFiles ("file " ++ file ++ " is missing")
1345 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1346 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1347 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1349 m <- doesFileExistOnPath ghci_lib_file dirs
1350 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1351 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1353 ghci_lib_file = lib <.> "o"
1355 -- automatically build the GHCi version of a batch lib,
1356 -- using ld --whole-archive.
1358 autoBuildGHCiLib :: String -> String -> String -> IO ()
1359 autoBuildGHCiLib dir batch_file ghci_file = do
1360 let ghci_lib_file = dir ++ '/':ghci_file
1361 batch_lib_file = dir ++ '/':batch_file
1362 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1363 #if defined(darwin_HOST_OS)
1364 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1365 #elif defined(mingw32_HOST_OS)
1366 execDir <- getLibDir
1367 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1369 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1371 when (r /= ExitSuccess) $ exitWith r
1372 hPutStrLn stderr (" done.")
1374 -- -----------------------------------------------------------------------------
1375 -- Searching for modules
1379 findModules :: [FilePath] -> IO [String]
1381 mms <- mapM searchDir paths
1384 searchDir path prefix = do
1385 fs <- getDirectoryEntries path `catch` \_ -> return []
1386 searchEntries path prefix fs
1388 searchEntries path prefix [] = return []
1389 searchEntries path prefix (f:fs)
1390 | looks_like_a_module = do
1391 ms <- searchEntries path prefix fs
1392 return (prefix `joinModule` f : ms)
1393 | looks_like_a_component = do
1394 ms <- searchDir (path </> f) (prefix `joinModule` f)
1395 ms' <- searchEntries path prefix fs
1398 searchEntries path prefix fs
1401 (base,suffix) = splitFileExt f
1402 looks_like_a_module =
1403 suffix `elem` haskell_suffixes &&
1404 all okInModuleName base
1405 looks_like_a_component =
1406 null suffix && all okInModuleName base
1412 -- ---------------------------------------------------------------------------
1413 -- expanding environment variables in the package configuration
1415 expandEnvVars :: String -> Force -> IO String
1416 expandEnvVars str0 force = go str0 ""
1418 go "" acc = return $! reverse acc
1419 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1420 = do value <- lookupEnvVar var
1421 go rest (reverse value ++ acc)
1422 where close c = c == '}' || c == '\n' -- don't span newlines
1426 lookupEnvVar :: String -> IO String
1428 catch (System.Environment.getEnv nm)
1429 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1433 -----------------------------------------------------------------------------
1435 getProgramName :: IO String
1436 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1437 where str `withoutSuffix` suff
1438 | suff `isSuffixOf` str = take (length str - length suff) str
1441 bye :: String -> IO a
1442 bye s = putStr s >> exitWith ExitSuccess
1444 die :: String -> IO a
1447 dieWith :: Int -> String -> IO a
1450 prog <- getProgramName
1451 hPutStrLn stderr (prog ++ ": " ++ s)
1452 exitWith (ExitFailure ec)
1454 dieOrForceAll :: Force -> String -> IO ()
1455 dieOrForceAll ForceAll s = ignoreError s
1456 dieOrForceAll _other s = dieForcible s
1458 ignoreError :: String -> IO ()
1459 ignoreError s = reportError (s ++ " (ignoring)")
1461 reportError :: String -> IO ()
1462 reportError s = do hFlush stdout; hPutStrLn stderr s
1464 dieForcible :: String -> IO ()
1465 dieForcible s = die (s ++ " (use --force to override)")
1467 my_head :: String -> [a] -> a
1468 my_head s [] = error s
1469 my_head _ (x : _) = x
1471 -----------------------------------------
1472 -- Cut and pasted from ghc/compiler/main/SysTools
1474 #if defined(mingw32_HOST_OS)
1475 subst :: Char -> Char -> String -> String
1476 subst a b ls = map (\ x -> if x == a then b else x) ls
1478 unDosifyPath :: FilePath -> FilePath
1479 unDosifyPath xs = subst '\\' '/' xs
1481 getLibDir :: IO (Maybe String)
1482 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1484 -- (getExecDir cmd) returns the directory in which the current
1485 -- executable, which should be called 'cmd', is running
1486 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1487 -- you'll get "/a/b/c" back as the result
1488 getExecDir :: String -> IO (Maybe String)
1490 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1491 where initN n = reverse . drop n . reverse
1492 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1494 getExecPath :: IO (Maybe String)
1496 allocaArray len $ \buf -> do
1497 ret <- getModuleFileName nullPtr buf len
1498 if ret == 0 then return Nothing
1499 else liftM Just $ peekCString buf
1500 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1502 foreign import stdcall unsafe "GetModuleFileNameA"
1503 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1506 getLibDir :: IO (Maybe String)
1507 getLibDir = return Nothing
1510 -----------------------------------------
1511 -- Adapted from ghc/compiler/utils/Panic
1513 installSignalHandlers :: IO ()
1514 installSignalHandlers = do
1515 threadid <- myThreadId
1517 interrupt = Exception.throwTo threadid
1518 (Exception.ErrorCall "interrupted")
1520 #if !defined(mingw32_HOST_OS)
1521 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1522 _ <- installHandler sigINT (Catch interrupt) Nothing
1524 #elif __GLASGOW_HASKELL__ >= 603
1525 -- GHC 6.3+ has support for console events on Windows
1526 -- NOTE: running GHCi under a bash shell for some reason requires
1527 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1528 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1529 -- why --SDM 17/12/2004
1530 let sig_handler ControlC = interrupt
1531 sig_handler Break = interrupt
1532 sig_handler _ = return ()
1534 _ <- installHandler (Catch sig_handler)
1537 return () -- nothing
1540 #if __GLASGOW_HASKELL__ <= 604
1541 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1542 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1545 #if mingw32_HOST_OS || mingw32_TARGET_OS
1546 throwIOIO :: Exception.IOException -> IO a
1547 throwIOIO = Exception.throwIO
1549 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1550 catchIO = Exception.catch
1553 catchError :: IO a -> (String -> IO a) -> IO a
1554 catchError io handler = io `Exception.catch` handler'
1555 where handler' (Exception.ErrorCall err) = handler err
1558 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1559 writeBinaryFileAtomic targetFile obj =
1560 withFileAtomic targetFile $ \h -> do
1561 hSetBinaryMode h True
1562 B.hPutStr h (Bin.encode obj)
1564 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1565 writeFileUtf8Atomic targetFile content =
1566 withFileAtomic targetFile $ \h -> do
1567 #if __GLASGOW_HASKELL__ >= 612
1572 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1573 -- to use text files here, rather than binary files.
1574 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1575 withFileAtomic targetFile write_content = do
1576 (newFile, newHandle) <- openNewFile targetDir template
1577 do write_content newHandle
1579 #if mingw32_HOST_OS || mingw32_TARGET_OS
1580 renameFile newFile targetFile
1581 -- If the targetFile exists then renameFile will fail
1582 `catchIO` \err -> do
1583 exists <- doesFileExist targetFile
1585 then do removeFile targetFile
1586 -- Big fat hairy race condition
1587 renameFile newFile targetFile
1588 -- If the removeFile succeeds and the renameFile fails
1589 -- then we've lost the atomic property.
1592 renameFile newFile targetFile
1594 `Exception.onException` do hClose newHandle
1597 template = targetName <.> "tmp"
1598 targetDir | null targetDir_ = "."
1599 | otherwise = targetDir_
1600 --TODO: remove this when takeDirectory/splitFileName is fixed
1601 -- to always return a valid dir
1602 (targetDir_,targetName) = splitFileName targetFile
1604 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1605 openNewFile dir template = do
1606 #if __GLASGOW_HASKELL__ >= 612
1607 -- this was added to System.IO in 6.12.1
1608 -- we must use this version because the version below opens the file
1610 openTempFileWithDefaultPermissions dir template
1612 -- Ugh, this is a copy/paste of code from the base library, but
1613 -- if uses 666 rather than 600 for the permissions.
1617 -- We split off the last extension, so we can use .foo.ext files
1618 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1619 -- below filepath in the hierarchy here.
1621 case break (== '.') $ reverse template of
1622 -- First case: template contains no '.'s. Just re-reverse it.
1623 (rev_suffix, "") -> (reverse rev_suffix, "")
1624 -- Second case: template contains at least one '.'. Strip the
1625 -- dot from the prefix and prepend it to the suffix (if we don't
1626 -- do this, the unique number will get added after the '.' and
1627 -- thus be part of the extension, which is wrong.)
1628 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1629 -- Otherwise, something is wrong, because (break (== '.')) should
1630 -- always return a pair with either the empty string or a string
1631 -- beginning with '.' as the second component.
1632 _ -> error "bug in System.IO.openTempFile"
1634 oflags = rw_flags .|. o_EXCL
1636 #if __GLASGOW_HASKELL__ < 611
1637 withFilePath = withCString
1641 fd <- withFilePath filepath $ \ f ->
1642 c_open f oflags 0o666
1647 then findTempName (x+1)
1648 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1650 -- XXX We want to tell fdToHandle what the filepath is,
1651 -- as any exceptions etc will only be able to report the
1654 #if __GLASGOW_HASKELL__ >= 609
1657 fdToHandle (fromIntegral fd)
1659 `Exception.onException` c_close fd
1660 return (filepath, h)
1662 filename = prefix ++ show x ++ suffix
1663 filepath = dir `combine` filename
1665 -- XXX Copied from GHC.Handle
1666 std_flags, output_flags, rw_flags :: CInt
1667 std_flags = o_NONBLOCK .|. o_NOCTTY
1668 output_flags = std_flags .|. o_CREAT
1669 rw_flags = output_flags .|. o_RDWR
1670 #endif /* GLASGOW_HASKELL < 612 */
1672 -- | The function splits the given string to substrings
1673 -- using 'isSearchPathSeparator'.
1674 parseSearchPath :: String -> [FilePath]
1675 parseSearchPath path = split path
1677 split :: String -> [String]
1681 _:rest -> chunk : split rest
1685 #ifdef mingw32_HOST_OS
1686 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1690 (chunk', rest') = break isSearchPathSeparator s
1692 readUTF8File :: FilePath -> IO String
1693 readUTF8File file = do
1694 h <- openFile file ReadMode
1695 #if __GLASGOW_HASKELL__ >= 612
1696 -- fix the encoding to UTF-8