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 import qualified Control.Exception as Exception
36 import Data.Char ( isSpace, toLower )
38 import System.Directory ( doesDirectoryExist, getDirectoryContents,
39 doesFileExist, renameFile, removeFile )
40 import System.Exit ( exitWith, ExitCode(..) )
41 import System.Environment ( getArgs, getProgName, getEnv )
43 import System.IO.Error (try)
45 import Control.Concurrent
47 import qualified Data.ByteString.Lazy as B
48 import qualified Data.Binary as Bin
49 import qualified Data.Binary.Get as Bin
51 #if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS)
52 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
57 #if __GLASGOW_HASKELL__ < 612
58 import System.Posix.Internals
59 import GHC.Handle (fdToHandle)
62 #ifdef mingw32_HOST_OS
63 import GHC.ConsoleHandler
65 import System.Posix hiding (fdToHandle)
68 import IO ( isPermissionError )
71 import System.Process(runInteractiveCommand)
72 import qualified System.Info(os)
75 #if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
76 import System.Console.Terminfo as Terminfo
79 -- -----------------------------------------------------------------------------
86 case getOpt Permute (flags ++ deprecFlags) args of
87 (cli,_,[]) | FlagHelp `elem` cli -> do
88 prog <- getProgramName
89 bye (usageInfo (usageHeader prog) flags)
90 (cli,_,[]) | FlagVersion `elem` cli ->
93 case getVerbosity Normal cli of
94 Right v -> runit v cli nonopts
97 prog <- getProgramName
98 die (concat errors ++ usageInfo (usageHeader prog) flags)
100 -- -----------------------------------------------------------------------------
101 -- Command-line syntax
108 | FlagConfig FilePath
109 | FlagGlobalConfig FilePath
117 | FlagVerbosity (Maybe String)
120 flags :: [OptDescr Flag]
122 Option [] ["user"] (NoArg FlagUser)
123 "use the current user's package database",
124 Option [] ["global"] (NoArg FlagGlobal)
125 "use the global package database",
126 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
127 "use the specified package config file",
128 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
129 "location of the global package config",
130 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
131 "never read the user package database",
132 Option [] ["force"] (NoArg FlagForce)
133 "ignore missing dependencies, directories, and libraries",
134 Option [] ["force-files"] (NoArg FlagForceFiles)
135 "ignore missing directories and libraries only",
136 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
137 "automatically build libs for GHCi (with register)",
138 Option ['?'] ["help"] (NoArg FlagHelp)
139 "display this help and exit",
140 Option ['V'] ["version"] (NoArg FlagVersion)
141 "output version information and exit",
142 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
143 "print output in easy-to-parse format for some commands",
144 Option [] ["names-only"] (NoArg FlagNamesOnly)
145 "only print package names, not versions; can only be used with list --simple-output",
146 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
147 "ignore case for substring matching",
148 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
149 "verbosity level (0-2, default 1)"
152 data Verbosity = Silent | Normal | Verbose
153 deriving (Show, Eq, Ord)
155 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
156 getVerbosity v [] = Right v
157 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
158 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
159 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
160 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
161 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
162 getVerbosity v (_ : fs) = getVerbosity v fs
164 deprecFlags :: [OptDescr Flag]
166 -- put deprecated flags here
169 ourCopyright :: String
170 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
172 usageHeader :: String -> String
173 usageHeader prog = substProg prog $
175 " $p init {path}\n" ++
176 " Create and initialise a package database at the location {path}.\n" ++
177 " Packages can be registered in the new database using the register\n" ++
178 " command with --package-conf={path}. To use the new database with GHC,\n" ++
179 " use GHC's -package-conf flag.\n" ++
181 " $p register {filename | -}\n" ++
182 " Register the package using the specified installed package\n" ++
183 " description. The syntax for the latter is given in the $p\n" ++
184 " documentation. The input file should be encoded in UTF-8.\n" ++
186 " $p update {filename | -}\n" ++
187 " Register the package, overwriting any other package with the\n" ++
188 " same name. The input file should be encoded in UTF-8.\n" ++
190 " $p unregister {pkg-id}\n" ++
191 " Unregister the specified package.\n" ++
193 " $p expose {pkg-id}\n" ++
194 " Expose the specified package.\n" ++
196 " $p hide {pkg-id}\n" ++
197 " Hide the specified package.\n" ++
199 " $p list [pkg]\n" ++
200 " List registered packages in the global database, and also the\n" ++
201 " user database if --user is given. If a package name is given\n" ++
202 " all the registered versions will be listed in ascending order.\n" ++
203 " Accepts the --simple-output flag.\n" ++
206 " Generate a graph of the package dependencies in a form suitable\n" ++
207 " for input for the graphviz tools. For example, to generate a PDF" ++
208 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
210 " $p find-module {module}\n" ++
211 " List registered packages exposing module {module} in the global\n" ++
212 " database, and also the user database if --user is given.\n" ++
213 " All the registered versions will be listed in ascending order.\n" ++
214 " Accepts the --simple-output flag.\n" ++
216 " $p latest {pkg-id}\n" ++
217 " Prints the highest registered version of a package.\n" ++
220 " Check the consistency of package depenencies and list broken packages.\n" ++
221 " Accepts the --simple-output flag.\n" ++
223 " $p describe {pkg}\n" ++
224 " Give the registered description for the specified package. The\n" ++
225 " description is returned in precisely the syntax required by $p\n" ++
228 " $p field {pkg} {field}\n" ++
229 " Extract the specified field of the package description for the\n" ++
230 " specified package. Accepts comma-separated multiple fields.\n" ++
233 " Dump the registered description for every package. This is like\n" ++
234 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
235 " by tools that parse the results, rather than humans. The output is\n" ++
236 " always encoded in UTF-8, regardless of the current locale.\n" ++
239 " Regenerate the package database cache. This command should only be\n" ++
240 " necessary if you added a package to the database by dropping a file\n" ++
241 " into the database directory manually. By default, the global DB\n" ++
242 " is recached; to recache a different DB use --user or --package-conf\n" ++
243 " as appropriate.\n" ++
245 " Substring matching is supported for {module} in find-module and\n" ++
246 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
247 " open substring ends (prefix*, *suffix, *infix*).\n" ++
249 " When asked to modify a database (register, unregister, update,\n"++
250 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
251 " default. Specifying --user causes it to act on the user database,\n"++
252 " or --package-conf can be used to act on another database\n"++
253 " entirely. When multiple of these options are given, the rightmost\n"++
254 " one is used as the database to act upon.\n"++
256 " Commands that query the package database (list, tree, latest, describe,\n"++
257 " field) operate on the list of databases specified by the flags\n"++
258 " --user, --global, and --package-conf. If none of these flags are\n"++
259 " given, the default is --global --user.\n"++
261 " The following optional flags are also accepted:\n"
263 substProg :: String -> String -> String
265 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
266 substProg prog (c:xs) = c : substProg prog xs
268 -- -----------------------------------------------------------------------------
271 data Force = NoForce | ForceFiles | ForceAll | CannotForce
274 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
276 runit :: Verbosity -> [Flag] -> [String] -> IO ()
277 runit verbosity cli nonopts = do
278 installSignalHandlers -- catch ^C and clean up
279 prog <- getProgramName
282 | FlagForce `elem` cli = ForceAll
283 | FlagForceFiles `elem` cli = ForceFiles
284 | otherwise = NoForce
285 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
286 splitFields fields = unfoldr splitComma (',':fields)
287 where splitComma "" = Nothing
288 splitComma fs = Just $ break (==',') (tail fs)
290 substringCheck :: String -> Maybe (String -> Bool)
291 substringCheck "" = Nothing
292 substringCheck "*" = Just (const True)
293 substringCheck [_] = Nothing
294 substringCheck (h:t) =
295 case (h, init t, last t) of
296 ('*',s,'*') -> Just (isInfixOf (f s) . f)
297 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
298 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
300 where f | FlagIgnoreCase `elem` cli = map toLower
303 glob x | System.Info.os=="mingw32" = do
304 -- glob echoes its argument, after win32 filename globbing
305 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
306 txt <- hGetContents o
308 glob x | otherwise = return [x]
311 -- first, parse the command
314 -- dummy command to demonstrate usage and permit testing
315 -- without messing things up; use glob to selectively enable
316 -- windows filename globbing for file parameters
317 -- register, update, FlagGlobalConfig, FlagConfig; others?
318 ["glob", filename] -> do
320 glob filename >>= print
322 ["init", filename] ->
323 initPackageDB filename verbosity cli
324 ["register", filename] ->
325 registerPackage filename verbosity cli auto_ghci_libs False force
326 ["update", filename] ->
327 registerPackage filename verbosity cli auto_ghci_libs True force
328 ["unregister", pkgid_str] -> do
329 pkgid <- readGlobPkgId pkgid_str
330 unregisterPackage pkgid verbosity cli force
331 ["expose", pkgid_str] -> do
332 pkgid <- readGlobPkgId pkgid_str
333 exposePackage pkgid verbosity cli force
334 ["hide", pkgid_str] -> do
335 pkgid <- readGlobPkgId pkgid_str
336 hidePackage pkgid verbosity cli force
338 listPackages verbosity cli Nothing Nothing
339 ["list", pkgid_str] ->
340 case substringCheck pkgid_str of
341 Nothing -> do pkgid <- readGlobPkgId pkgid_str
342 listPackages verbosity cli (Just (Id pkgid)) Nothing
343 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
345 showPackageDot verbosity cli
346 ["find-module", moduleName] -> do
347 let match = maybe (==moduleName) id (substringCheck moduleName)
348 listPackages verbosity cli Nothing (Just match)
349 ["latest", pkgid_str] -> do
350 pkgid <- readGlobPkgId pkgid_str
351 latestPackage verbosity cli pkgid
352 ["describe", pkgid_str] ->
353 case substringCheck pkgid_str of
354 Nothing -> do pkgid <- readGlobPkgId pkgid_str
355 describePackage verbosity cli (Id pkgid)
356 Just m -> describePackage verbosity cli (Substring pkgid_str m)
357 ["field", pkgid_str, fields] ->
358 case substringCheck pkgid_str of
359 Nothing -> do pkgid <- readGlobPkgId pkgid_str
360 describeField verbosity cli (Id pkgid)
362 Just m -> describeField verbosity cli (Substring pkgid_str m)
365 checkConsistency verbosity cli
368 dumpPackages verbosity cli
371 recache verbosity cli
374 die ("missing command\n" ++
375 usageInfo (usageHeader prog) flags)
377 die ("command-line syntax error\n" ++
378 usageInfo (usageHeader prog) flags)
380 parseCheck :: ReadP a a -> String -> String -> IO a
381 parseCheck parser str what =
382 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
384 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
386 readGlobPkgId :: String -> IO PackageIdentifier
387 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
389 parseGlobPackageId :: ReadP r PackageIdentifier
395 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
397 -- globVersion means "all versions"
398 globVersion :: Version
399 globVersion = Version{ versionBranch=[], versionTags=["*"] }
401 -- -----------------------------------------------------------------------------
404 -- Some commands operate on a single database:
405 -- register, unregister, expose, hide
406 -- however these commands also check the union of the available databases
407 -- in order to check consistency. For example, register will check that
408 -- dependencies exist before registering a package.
410 -- Some commands operate on multiple databases, with overlapping semantics:
411 -- list, describe, field
414 = PackageDB { location :: FilePath,
415 packages :: [InstalledPackageInfo] }
417 type PackageDBStack = [PackageDB]
418 -- A stack of package databases. Convention: head is the topmost
421 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
422 allPackagesInStack = concatMap packages
424 getPkgDatabases :: Verbosity
425 -> Bool -- we are modifying, not reading
426 -> Bool -- read caches, if available
428 -> IO (PackageDBStack,
429 -- the real package DB stack: [global,user] ++
430 -- DBs specified on the command line with -f.
432 -- which one to modify, if any
434 -- the package DBs specified on the command
435 -- line, or [global,user] otherwise. This
436 -- is used as the list of package DBs for
437 -- commands that just read the DB, such as 'list'.
439 getPkgDatabases verbosity modify use_cache my_flags = do
440 -- first we determine the location of the global package config. On Windows,
441 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
442 -- location is passed to the binary using the --global-config flag by the
444 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
446 case [ f | FlagGlobalConfig f <- my_flags ] of
447 [] -> do mb_dir <- getLibDir
449 Nothing -> die err_msg
451 r <- lookForPackageDBIn dir
453 Nothing -> die ("Can't find package database in " ++ dir)
454 Just path -> return path
455 fs -> return (last fs)
457 let no_user_db = FlagNoUserDb `elem` my_flags
459 -- get the location of the user package database, and create it if necessary
460 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
461 e_appdir <- try $ getAppUserDataDirectory "ghc"
464 if no_user_db then return Nothing else
466 Left _ -> return Nothing
468 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
469 dir = appdir </> subdir
470 r <- lookForPackageDBIn dir
472 Nothing -> return (Just (dir </> "package.conf.d", False))
473 Just f -> return (Just (f, True))
475 -- If the user database doesn't exist, and this command isn't a
476 -- "modify" command, then we won't attempt to create or use it.
478 | Just (user_conf,user_exists) <- mb_user_conf,
479 modify || user_exists = [user_conf, global_conf]
480 | otherwise = [global_conf]
482 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
485 Left _ -> sys_databases
487 | last cs == "" -> init cs ++ sys_databases
489 where cs = parseSearchPath path
491 -- The "global" database is always the one at the bottom of the stack.
492 -- This is the database we modify by default.
493 virt_global_conf = last env_stack
495 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
496 where is_db_flag FlagUser
497 | Just (user_conf, _user_exists) <- mb_user_conf
499 is_db_flag FlagGlobal = Just virt_global_conf
500 is_db_flag (FlagConfig f) = Just f
501 is_db_flag _ = Nothing
503 let flag_db_names | null db_flags = env_stack
504 | otherwise = reverse (nub db_flags)
506 -- For a "modify" command, treat all the databases as
507 -- a stack, where we are modifying the top one, but it
508 -- can refer to packages in databases further down the
511 -- -f flags on the command line add to the database
512 -- stack, unless any of them are present in the stack
514 let final_stack = filter (`notElem` env_stack)
515 [ f | FlagConfig f <- reverse my_flags ]
518 -- the database we actually modify is the one mentioned
519 -- rightmost on the command-line.
521 | not modify = Nothing
522 | null db_flags = Just virt_global_conf
523 | otherwise = Just (last db_flags)
525 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
527 let flag_db_stack = [ db | db_name <- flag_db_names,
528 db <- db_stack, location db == db_name ]
530 return (db_stack, to_modify, flag_db_stack)
533 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
534 lookForPackageDBIn dir = do
535 let path_dir = dir </> "package.conf.d"
536 exists_dir <- doesDirectoryExist path_dir
537 if exists_dir then return (Just path_dir) else do
538 let path_file = dir </> "package.conf"
539 exists_file <- doesFileExist path_file
540 if exists_file then return (Just path_file) else return Nothing
542 readParseDatabase :: Verbosity
543 -> Maybe (FilePath,Bool)
548 readParseDatabase verbosity mb_user_conf use_cache path
549 -- the user database (only) is allowed to be non-existent
550 | Just (user_conf,False) <- mb_user_conf, path == user_conf
551 = return PackageDB { location = path, packages = [] }
553 = do e <- try $ getDirectoryContents path
556 pkgs <- parseMultiPackageConf verbosity path
557 return PackageDB{ location = path, packages = pkgs }
559 | not use_cache -> ignore_cache
561 let cache = path </> cachefilename
562 tdir <- getModificationTime path
563 e_tcache <- try $ getModificationTime cache
566 when (verbosity > Normal) $
567 warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
570 | tcache >= tdir -> do
571 when (verbosity > Normal) $
572 putStrLn ("using cache: " ++ cache)
573 pkgs <- myReadBinPackageDB cache
574 let pkgs' = map convertPackageInfoIn pkgs
575 return PackageDB { location = path, packages = pkgs' }
577 when (verbosity >= Normal) $ do
578 warn ("WARNING: cache is out of date: " ++ cache)
579 warn " use 'ghc-pkg recache' to fix."
583 let confs = filter (".conf" `isSuffixOf`) fs
584 pkgs <- mapM (parseSingletonPackageConf verbosity) $
586 return PackageDB { location = path, packages = pkgs }
588 -- read the package.cache file strictly, to work around a problem with
589 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
590 -- after it has been completely read, leading to a sharing violation
592 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
593 myReadBinPackageDB filepath = do
594 h <- openBinaryFile filepath ReadMode
596 b <- B.hGet h (fromIntegral sz)
598 return $ Bin.runGet Bin.get b
600 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
601 parseMultiPackageConf verbosity file = do
602 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
603 str <- readUTF8File file
604 let pkgs = map convertPackageInfoIn $ read str
605 Exception.evaluate pkgs
607 die ("error while parsing " ++ file ++ ": " ++ show e)
609 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
610 parseSingletonPackageConf verbosity file = do
611 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
612 readUTF8File file >>= parsePackageInfo
614 cachefilename :: FilePath
615 cachefilename = "package.cache"
617 -- -----------------------------------------------------------------------------
618 -- Creating a new package DB
620 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
621 initPackageDB filename verbosity _flags = do
622 let eexist = die ("cannot create: " ++ filename ++ " already exists")
623 b1 <- doesFileExist filename
625 b2 <- doesDirectoryExist filename
627 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
629 -- -----------------------------------------------------------------------------
632 registerPackage :: FilePath
635 -> Bool -- auto_ghci_libs
639 registerPackage input verbosity my_flags auto_ghci_libs update force = do
640 (db_stack, Just to_modify, _flag_dbs) <-
641 getPkgDatabases verbosity True True my_flags
644 db_to_operate_on = my_head "register" $
645 filter ((== to_modify).location) db_stack
650 when (verbosity >= Normal) $
651 putStr "Reading package info from stdin ... "
652 #if __GLASGOW_HASKELL__ >= 612
653 -- fix the encoding to UTF-8, since this is an interchange format
654 hSetEncoding stdin utf8
658 when (verbosity >= Normal) $
659 putStr ("Reading package info from " ++ show f ++ " ... ")
662 expanded <- expandEnvVars s force
664 pkg <- parsePackageInfo expanded
665 when (verbosity >= Normal) $
668 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
669 -- truncate the stack for validation, because we don't allow
670 -- packages lower in the stack to refer to those higher up.
671 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
673 removes = [ RemovePackage p
674 | p <- packages db_to_operate_on,
675 sourcePackageId p == sourcePackageId pkg ]
677 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
681 -> IO InstalledPackageInfo
682 parsePackageInfo str =
683 case parseInstalledPackageInfo str of
684 ParseOk _warns ok -> return ok
685 ParseFailed err -> case locatedErrorMsg err of
686 (Nothing, s) -> die s
687 (Just l, s) -> die (show l ++ ": " ++ s)
689 -- -----------------------------------------------------------------------------
690 -- Making changes to a package database
692 data DBOp = RemovePackage InstalledPackageInfo
693 | AddPackage InstalledPackageInfo
694 | ModifyPackage InstalledPackageInfo
696 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
697 changeDB verbosity cmds db = do
698 let db' = updateInternalDB db cmds
699 isfile <- doesFileExist (location db)
701 then writeNewConfig verbosity (location db') (packages db')
703 createDirectoryIfMissing True (location db)
704 changeDBDir verbosity cmds db'
706 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
707 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
709 do_cmd pkgs (RemovePackage p) =
710 filter ((/= installedPackageId p) . installedPackageId) pkgs
711 do_cmd pkgs (AddPackage p) = p : pkgs
712 do_cmd pkgs (ModifyPackage p) =
713 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
716 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
717 changeDBDir verbosity cmds db = do
719 updateDBCache verbosity db
721 do_cmd (RemovePackage p) = do
722 let file = location db </> display (installedPackageId p) <.> "conf"
723 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
725 do_cmd (AddPackage p) = do
726 let file = location db </> display (installedPackageId p) <.> "conf"
727 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
728 writeFileUtf8Atomic file (showInstalledPackageInfo p)
729 do_cmd (ModifyPackage p) =
730 do_cmd (AddPackage p)
732 updateDBCache :: Verbosity -> PackageDB -> IO ()
733 updateDBCache verbosity db = do
734 let filename = location db </> cachefilename
735 when (verbosity > Normal) $
736 putStrLn ("writing cache " ++ filename)
737 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
739 if isPermissionError e
740 then die (filename ++ ": you don't have permission to modify this file")
743 -- -----------------------------------------------------------------------------
744 -- Exposing, Hiding, Unregistering are all similar
746 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
747 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
749 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
750 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
752 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
753 unregisterPackage = modifyPackage RemovePackage
756 :: (InstalledPackageInfo -> DBOp)
762 modifyPackage fn pkgid verbosity my_flags force = do
763 (db_stack, Just _to_modify, _flag_dbs) <-
764 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
766 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
768 db_name = location db
771 pids = map sourcePackageId ps
773 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
774 new_db = updateInternalDB db cmds
776 old_broken = brokenPackages (allPackagesInStack db_stack)
777 rest_of_stack = filter ((/= db_name) . location) db_stack
778 new_stack = new_db : rest_of_stack
779 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
780 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
782 when (not (null newly_broken)) $
783 dieOrForceAll force ("unregistering " ++ display pkgid ++
784 " would break the following packages: "
785 ++ unwords (map display newly_broken))
787 changeDB verbosity cmds db
789 recache :: Verbosity -> [Flag] -> IO ()
790 recache verbosity my_flags = do
791 (db_stack, Just to_modify, _flag_dbs) <-
792 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
794 db_to_operate_on = my_head "recache" $
795 filter ((== to_modify).location) db_stack
797 changeDB verbosity [] db_to_operate_on
799 -- -----------------------------------------------------------------------------
802 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
803 -> Maybe (String->Bool)
805 listPackages verbosity my_flags mPackageName mModuleName = do
806 let simple_output = FlagSimpleOutput `elem` my_flags
807 (db_stack, _, flag_db_stack) <-
808 getPkgDatabases verbosity False True{-use cache-} my_flags
810 let db_stack_filtered -- if a package is given, filter out all other packages
811 | Just this <- mPackageName =
812 [ db{ packages = filter (this `matchesPkg`) (packages db) }
813 | db <- flag_db_stack ]
814 | Just match <- mModuleName = -- packages which expose mModuleName
815 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
816 | db <- flag_db_stack ]
817 | otherwise = flag_db_stack
820 = [ db{ packages = sort_pkgs (packages db) }
821 | db <- db_stack_filtered ]
822 where sort_pkgs = sortBy cmpPkgIds
823 cmpPkgIds pkg1 pkg2 =
824 case pkgName p1 `compare` pkgName p2 of
827 EQ -> pkgVersion p1 `compare` pkgVersion p2
828 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
830 stack = reverse db_stack_sorted
832 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
834 pkg_map = allPackagesInStack db_stack
835 broken = map sourcePackageId (brokenPackages pkg_map)
837 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
838 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
840 pp_pkgs = map pp_pkg pkg_confs
842 | sourcePackageId p `elem` broken = printf "{%s}" doc
844 | otherwise = printf "(%s)" doc
845 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
848 InstalledPackageId ipid = installedPackageId p
849 pkg = display (sourcePackageId p)
851 show_simple = simplePackageList my_flags . allPackagesInStack
853 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
854 prog <- getProgramName
855 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
857 if simple_output then show_simple stack else do
859 #if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
860 mapM_ show_normal stack
863 show_colour withF db =
864 mconcat $ map (<#> termText "\n") $
865 (termText (location db) :
866 map (termText " " <#>) (map pp_pkg (packages db)))
869 | sourcePackageId p `elem` broken = withF Red doc
871 | otherwise = withF Blue doc
872 where doc | verbosity >= Verbose
873 = termText (printf "%s (%s)" pkg ipid)
877 InstalledPackageId ipid = installedPackageId p
878 pkg = display (sourcePackageId p)
880 is_tty <- hIsTerminalDevice stdout
882 then mapM_ show_normal stack
883 else do tty <- Terminfo.setupTermFromEnv
884 case Terminfo.getCapability tty withForegroundColor of
885 Nothing -> mapM_ show_normal stack
886 Just w -> runTermOutput tty $ mconcat $
887 map (show_colour w) stack
890 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
891 simplePackageList my_flags pkgs = do
892 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
894 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
895 when (not (null pkgs)) $
896 hPutStrLn stdout $ concat $ intersperse " " strs
898 showPackageDot :: Verbosity -> [Flag] -> IO ()
899 showPackageDot verbosity myflags = do
900 (_, _, flag_db_stack) <-
901 getPkgDatabases verbosity False True{-use cache-} myflags
903 let all_pkgs = allPackagesInStack flag_db_stack
904 ipix = PackageIndex.fromList all_pkgs
907 let quote s = '"':s ++ "\""
908 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
910 let from = display (sourcePackageId p),
912 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
913 let to = display (sourcePackageId dep)
917 -- -----------------------------------------------------------------------------
918 -- Prints the highest (hidden or exposed) version of a package
920 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
921 latestPackage verbosity my_flags pkgid = do
922 (_, _, flag_db_stack) <-
923 getPkgDatabases verbosity False True{-use cache-} my_flags
925 ps <- findPackages flag_db_stack (Id pkgid)
926 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
928 show_pkg [] = die "no matches"
929 show_pkg pids = hPutStrLn stdout (display (last pids))
931 -- -----------------------------------------------------------------------------
934 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
935 describePackage verbosity my_flags pkgarg = do
936 (_, _, flag_db_stack) <-
937 getPkgDatabases verbosity False True{-use cache-} my_flags
938 ps <- findPackages flag_db_stack pkgarg
941 dumpPackages :: Verbosity -> [Flag] -> IO ()
942 dumpPackages verbosity my_flags = do
943 (_, _, flag_db_stack) <-
944 getPkgDatabases verbosity False True{-use cache-} my_flags
945 doDump (allPackagesInStack flag_db_stack)
947 doDump :: [InstalledPackageInfo] -> IO ()
949 #if __GLASGOW_HASKELL__ >= 612
950 -- fix the encoding to UTF-8, since this is an interchange format
951 hSetEncoding stdout utf8
953 mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
955 -- PackageId is can have globVersion for the version
956 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
957 findPackages db_stack pkgarg
958 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
960 findPackagesByDB :: PackageDBStack -> PackageArg
961 -> IO [(PackageDB, [InstalledPackageInfo])]
962 findPackagesByDB db_stack pkgarg
963 = case [ (db, matched)
965 let matched = filter (pkgarg `matchesPkg`) (packages db),
966 not (null matched) ] of
967 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
970 pkg_msg (Id pkgid) = display pkgid
971 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
973 matches :: PackageIdentifier -> PackageIdentifier -> Bool
975 = (pkgName pid == pkgName pid')
976 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
978 realVersion :: PackageIdentifier -> Bool
979 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
980 -- when versionBranch == [], this is a glob
982 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
983 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
984 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
986 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
987 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
989 -- -----------------------------------------------------------------------------
992 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
993 describeField verbosity my_flags pkgarg fields = do
994 (_, _, flag_db_stack) <-
995 getPkgDatabases verbosity False True{-use cache-} my_flags
996 fns <- toFields fields
997 ps <- findPackages flag_db_stack pkgarg
998 let top_dir = takeDirectory (location (last flag_db_stack))
999 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
1000 where toFields [] = return []
1001 toFields (f:fs) = case toField f of
1002 Nothing -> die ("unknown field: " ++ f)
1003 Just fn -> do fns <- toFields fs
1005 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1007 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1008 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1009 -- with the current topdir (obtained from the -B option).
1010 mungePackagePaths top_dir ps = map munge_pkg ps
1012 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
1013 includeDirs = munge_paths (includeDirs p),
1014 libraryDirs = munge_paths (libraryDirs p),
1015 frameworkDirs = munge_paths (frameworkDirs p),
1016 haddockInterfaces = munge_paths (haddockInterfaces p),
1017 haddockHTMLs = munge_paths (haddockHTMLs p)
1020 munge_paths = map munge_path
1023 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1024 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1027 toHttpPath p = "file:///" ++ p
1029 maybePrefixMatch :: String -> String -> Maybe String
1030 maybePrefixMatch [] rest = Just rest
1031 maybePrefixMatch (_:_) [] = Nothing
1032 maybePrefixMatch (p:pat) (r:rest)
1033 | p == r = maybePrefixMatch pat rest
1034 | otherwise = Nothing
1036 toField :: String -> Maybe (InstalledPackageInfo -> String)
1037 -- backwards compatibility:
1038 toField "import_dirs" = Just $ strList . importDirs
1039 toField "source_dirs" = Just $ strList . importDirs
1040 toField "library_dirs" = Just $ strList . libraryDirs
1041 toField "hs_libraries" = Just $ strList . hsLibraries
1042 toField "extra_libraries" = Just $ strList . extraLibraries
1043 toField "include_dirs" = Just $ strList . includeDirs
1044 toField "c_includes" = Just $ strList . includes
1045 toField "package_deps" = Just $ strList . map display. depends
1046 toField "extra_cc_opts" = Just $ strList . ccOptions
1047 toField "extra_ld_opts" = Just $ strList . ldOptions
1048 toField "framework_dirs" = Just $ strList . frameworkDirs
1049 toField "extra_frameworks"= Just $ strList . frameworks
1050 toField s = showInstalledPackageInfoField s
1052 strList :: [String] -> String
1056 -- -----------------------------------------------------------------------------
1057 -- Check: Check consistency of installed packages
1059 checkConsistency :: Verbosity -> [Flag] -> IO ()
1060 checkConsistency verbosity my_flags = do
1061 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1062 -- check behaves like modify for the purposes of deciding which
1063 -- databases to use, because ordering is important.
1065 let simple_output = FlagSimpleOutput `elem` my_flags
1067 let pkgs = allPackagesInStack db_stack
1070 (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1072 then do when (not simple_output) $ do
1073 _ <- reportValidateErrors [] ws "" Nothing
1077 when (not simple_output) $ do
1078 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1079 _ <- reportValidateErrors es ws " " Nothing
1083 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1085 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1086 where not_in p = sourcePackageId p `notElem` all_ps
1087 all_ps = map sourcePackageId pkgs1
1089 let not_broken_pkgs = filterOut broken_pkgs pkgs
1090 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1091 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1093 when (not (null all_broken_pkgs)) $ do
1095 then simplePackageList my_flags all_broken_pkgs
1097 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1098 "listed above, or because they depend on a broken package.")
1099 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1101 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1104 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1105 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1106 closure pkgs db_stack = go pkgs db_stack
1108 go avail not_avail =
1109 case partition (depsAvailable avail) not_avail of
1110 ([], not_avail') -> (avail, not_avail')
1111 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1113 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1115 depsAvailable pkgs_ok pkg = null dangling
1116 where dangling = filter (`notElem` pids) (depends pkg)
1117 pids = map installedPackageId pkgs_ok
1119 -- we want mutually recursive groups of package to show up
1120 -- as broken. (#1750)
1122 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1123 brokenPackages pkgs = snd (closure [] pkgs)
1125 -- -----------------------------------------------------------------------------
1126 -- Manipulating package.conf files
1128 type InstalledPackageInfoString = InstalledPackageInfo_ String
1130 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1131 convertPackageInfoOut
1132 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1133 hiddenModules = h })) =
1134 pkgconf{ exposedModules = map display e,
1135 hiddenModules = map display h }
1137 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1138 convertPackageInfoIn
1139 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1140 hiddenModules = h })) =
1141 pkgconf{ exposedModules = map convert e,
1142 hiddenModules = map convert h }
1143 where convert = fromJust . simpleParse
1145 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1146 writeNewConfig verbosity filename ipis = do
1147 when (verbosity >= Normal) $
1148 hPutStr stdout "Writing new package config file... "
1149 createDirectoryIfMissing True $ takeDirectory filename
1150 let shown = concat $ intersperse ",\n "
1151 $ map (show . convertPackageInfoOut) ipis
1152 fileContents = "[" ++ shown ++ "\n]"
1153 writeFileUtf8Atomic filename fileContents
1155 if isPermissionError e
1156 then die (filename ++ ": you don't have permission to modify this file")
1158 when (verbosity >= Normal) $
1159 hPutStrLn stdout "done."
1161 -----------------------------------------------------------------------------
1162 -- Sanity-check a new package config, and automatically build GHCi libs
1165 type ValidateError = (Force,String)
1166 type ValidateWarning = String
1168 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1170 instance Monad Validate where
1171 return a = V $ return (a, [], [])
1173 (a, es, ws) <- runValidate m
1174 (b, es', ws') <- runValidate (k a)
1175 return (b,es++es',ws++ws')
1177 verror :: Force -> String -> Validate ()
1178 verror f s = V (return ((),[(f,s)],[]))
1180 vwarn :: String -> Validate ()
1181 vwarn s = V (return ((),[],["Warning: " ++ s]))
1183 liftIO :: IO a -> Validate a
1184 liftIO k = V (k >>= \a -> return (a,[],[]))
1186 -- returns False if we should die
1187 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1188 -> String -> Maybe Force -> IO Bool
1189 reportValidateErrors es ws prefix mb_force = do
1190 mapM_ (warn . (prefix++)) ws
1191 oks <- mapM report es
1195 | Just force <- mb_force
1197 then do reportError (prefix ++ s ++ " (ignoring)")
1199 else if f < CannotForce
1200 then do reportError (prefix ++ s ++ " (use --force to override)")
1202 else do reportError err
1204 | otherwise = do reportError err
1209 validatePackageConfig :: InstalledPackageInfo
1211 -> Bool -- auto-ghc-libs
1212 -> Bool -- update, or check
1215 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1216 (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1217 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1218 when (not ok) $ exitWith (ExitFailure 1)
1220 checkPackageConfig :: InstalledPackageInfo
1222 -> Bool -- auto-ghc-libs
1223 -> Bool -- update, or check
1225 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1226 checkInstalledPackageId pkg db_stack update
1228 checkDuplicates db_stack pkg update
1229 mapM_ (checkDep db_stack) (depends pkg)
1230 checkDuplicateDepends (depends pkg)
1231 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1232 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1233 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1235 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1236 -- ToDo: check these somehow?
1237 -- extra_libraries :: [String],
1238 -- c_includes :: [String],
1240 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1242 checkInstalledPackageId ipi db_stack update = do
1243 let ipid@(InstalledPackageId str) = installedPackageId ipi
1244 when (null str) $ verror CannotForce "missing id field"
1245 let dups = [ p | p <- allPackagesInStack db_stack,
1246 installedPackageId p == ipid ]
1247 when (not update && not (null dups)) $
1248 verror CannotForce $
1249 "package(s) with this id already exist: " ++
1250 unwords (map (display.packageId) dups)
1252 -- When the package name and version are put together, sometimes we can
1253 -- end up with a package id that cannot be parsed. This will lead to
1254 -- difficulties when the user wants to refer to the package later, so
1255 -- we check that the package id can be parsed properly here.
1256 checkPackageId :: InstalledPackageInfo -> Validate ()
1257 checkPackageId ipi =
1258 let str = display (sourcePackageId ipi) in
1259 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1261 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1262 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1264 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1265 checkDuplicates db_stack pkg update = do
1267 pkgid = sourcePackageId pkg
1268 pkgs = packages (head db_stack)
1270 -- Check whether this package id already exists in this DB
1272 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1273 verror CannotForce $
1274 "package " ++ display pkgid ++ " is already installed"
1277 uncasep = map toLower . display
1278 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1280 when (not update && not (null dups)) $ verror ForceAll $
1281 "Package names may be treated case-insensitively in the future.\n"++
1282 "Package " ++ display pkgid ++
1283 " overlaps with: " ++ unwords (map display dups)
1286 checkDir :: Bool -> String -> String -> Validate ()
1287 checkDir warn_only thisfield d
1288 | "$topdir" `isPrefixOf` d = return ()
1289 | "$httptopdir" `isPrefixOf` d = return ()
1290 -- can't check these, because we don't know what $(http)topdir is
1291 | isRelative d = verror ForceFiles $
1292 thisfield ++ ": " ++ d ++ " is a relative path"
1293 -- relative paths don't make any sense; #4134
1295 there <- liftIO $ doesDirectoryExist d
1297 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
1301 else verror ForceFiles msg
1303 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1304 checkDep db_stack pkgid
1305 | pkgid `elem` pkgids = return ()
1306 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1307 ++ "\" doesn't exist")
1309 all_pkgs = allPackagesInStack db_stack
1310 pkgids = map installedPackageId all_pkgs
1312 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1313 checkDuplicateDepends deps
1314 | null dups = return ()
1315 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1316 unwords (map display dups))
1318 dups = [ p | (p:_:_) <- group (sort deps) ]
1320 checkHSLib :: [String] -> Bool -> String -> Validate ()
1321 checkHSLib dirs auto_ghci_libs lib = do
1322 let batch_lib_file = "lib" ++ lib ++ ".a"
1323 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1325 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1327 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1329 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1330 doesFileExistOnPath file path = go path
1331 where go [] = return Nothing
1332 go (p:ps) = do b <- doesFileExistIn file p
1333 if b then return (Just p) else go ps
1335 doesFileExistIn :: String -> String -> IO Bool
1336 doesFileExistIn lib d
1337 | "$topdir" `isPrefixOf` d = return True
1338 | "$httptopdir" `isPrefixOf` d = return True
1339 | otherwise = doesFileExist (d </> lib)
1341 checkModules :: InstalledPackageInfo -> Validate ()
1342 checkModules pkg = do
1343 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1345 findModule modl = do
1346 -- there's no .hi file for GHC.Prim
1347 if modl == fromString "GHC.Prim" then return () else do
1348 let file = toFilePath modl <.> "hi"
1349 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1350 when (isNothing m) $
1351 verror ForceFiles ("file " ++ file ++ " is missing")
1353 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1354 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1355 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1357 m <- doesFileExistOnPath ghci_lib_file dirs
1358 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1359 warn ("warning: can't find GHCi lib " ++ ghci_lib_file)
1361 ghci_lib_file = lib <.> "o"
1363 -- automatically build the GHCi version of a batch lib,
1364 -- using ld --whole-archive.
1366 autoBuildGHCiLib :: String -> String -> String -> IO ()
1367 autoBuildGHCiLib dir batch_file ghci_file = do
1368 let ghci_lib_file = dir ++ '/':ghci_file
1369 batch_lib_file = dir ++ '/':batch_file
1370 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1371 #if defined(darwin_HOST_OS)
1372 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1373 #elif defined(mingw32_HOST_OS)
1374 execDir <- getLibDir
1375 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1377 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1379 when (r /= ExitSuccess) $ exitWith r
1380 hPutStrLn stderr (" done.")
1382 -- -----------------------------------------------------------------------------
1383 -- Searching for modules
1387 findModules :: [FilePath] -> IO [String]
1389 mms <- mapM searchDir paths
1392 searchDir path prefix = do
1393 fs <- getDirectoryEntries path `catch` \_ -> return []
1394 searchEntries path prefix fs
1396 searchEntries path prefix [] = return []
1397 searchEntries path prefix (f:fs)
1398 | looks_like_a_module = do
1399 ms <- searchEntries path prefix fs
1400 return (prefix `joinModule` f : ms)
1401 | looks_like_a_component = do
1402 ms <- searchDir (path </> f) (prefix `joinModule` f)
1403 ms' <- searchEntries path prefix fs
1406 searchEntries path prefix fs
1409 (base,suffix) = splitFileExt f
1410 looks_like_a_module =
1411 suffix `elem` haskell_suffixes &&
1412 all okInModuleName base
1413 looks_like_a_component =
1414 null suffix && all okInModuleName base
1420 -- ---------------------------------------------------------------------------
1421 -- expanding environment variables in the package configuration
1423 expandEnvVars :: String -> Force -> IO String
1424 expandEnvVars str0 force = go str0 ""
1426 go "" acc = return $! reverse acc
1427 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1428 = do value <- lookupEnvVar var
1429 go rest (reverse value ++ acc)
1430 where close c = c == '}' || c == '\n' -- don't span newlines
1434 lookupEnvVar :: String -> IO String
1436 catch (System.Environment.getEnv nm)
1437 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1441 -----------------------------------------------------------------------------
1443 getProgramName :: IO String
1444 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1445 where str `withoutSuffix` suff
1446 | suff `isSuffixOf` str = take (length str - length suff) str
1449 bye :: String -> IO a
1450 bye s = putStr s >> exitWith ExitSuccess
1452 die :: String -> IO a
1455 dieWith :: Int -> String -> IO a
1458 prog <- getProgramName
1459 hPutStrLn stderr (prog ++ ": " ++ s)
1460 exitWith (ExitFailure ec)
1462 dieOrForceAll :: Force -> String -> IO ()
1463 dieOrForceAll ForceAll s = ignoreError s
1464 dieOrForceAll _other s = dieForcible s
1466 warn :: String -> IO ()
1469 ignoreError :: String -> IO ()
1470 ignoreError s = reportError (s ++ " (ignoring)")
1472 reportError :: String -> IO ()
1473 reportError s = do hFlush stdout; hPutStrLn stderr s
1475 dieForcible :: String -> IO ()
1476 dieForcible s = die (s ++ " (use --force to override)")
1478 my_head :: String -> [a] -> a
1479 my_head s [] = error s
1480 my_head _ (x : _) = x
1482 -----------------------------------------
1483 -- Cut and pasted from ghc/compiler/main/SysTools
1485 #if defined(mingw32_HOST_OS)
1486 subst :: Char -> Char -> String -> String
1487 subst a b ls = map (\ x -> if x == a then b else x) ls
1489 unDosifyPath :: FilePath -> FilePath
1490 unDosifyPath xs = subst '\\' '/' xs
1492 getLibDir :: IO (Maybe String)
1493 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1495 -- (getExecDir cmd) returns the directory in which the current
1496 -- executable, which should be called 'cmd', is running
1497 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1498 -- you'll get "/a/b/c" back as the result
1499 getExecDir :: String -> IO (Maybe String)
1501 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1502 where initN n = reverse . drop n . reverse
1503 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1505 getExecPath :: IO (Maybe String)
1507 allocaArray len $ \buf -> do
1508 ret <- getModuleFileName nullPtr buf len
1509 if ret == 0 then return Nothing
1510 else liftM Just $ peekCString buf
1511 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1513 foreign import stdcall unsafe "GetModuleFileNameA"
1514 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1517 getLibDir :: IO (Maybe String)
1518 getLibDir = return Nothing
1521 -----------------------------------------
1522 -- Adapted from ghc/compiler/utils/Panic
1524 installSignalHandlers :: IO ()
1525 installSignalHandlers = do
1526 threadid <- myThreadId
1528 interrupt = Exception.throwTo threadid
1529 (Exception.ErrorCall "interrupted")
1531 #if !defined(mingw32_HOST_OS)
1532 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1533 _ <- installHandler sigINT (Catch interrupt) Nothing
1535 #elif __GLASGOW_HASKELL__ >= 603
1536 -- GHC 6.3+ has support for console events on Windows
1537 -- NOTE: running GHCi under a bash shell for some reason requires
1538 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1539 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1540 -- why --SDM 17/12/2004
1541 let sig_handler ControlC = interrupt
1542 sig_handler Break = interrupt
1543 sig_handler _ = return ()
1545 _ <- installHandler (Catch sig_handler)
1548 return () -- nothing
1551 #if __GLASGOW_HASKELL__ <= 604
1552 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1553 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1556 #if mingw32_HOST_OS || mingw32_TARGET_OS
1557 throwIOIO :: Exception.IOException -> IO a
1558 throwIOIO = Exception.throwIO
1560 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1561 catchIO = Exception.catch
1564 catchError :: IO a -> (String -> IO a) -> IO a
1565 catchError io handler = io `Exception.catch` handler'
1566 where handler' (Exception.ErrorCall err) = handler err
1569 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1570 writeBinaryFileAtomic targetFile obj =
1571 withFileAtomic targetFile $ \h -> do
1572 hSetBinaryMode h True
1573 B.hPutStr h (Bin.encode obj)
1575 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1576 writeFileUtf8Atomic targetFile content =
1577 withFileAtomic targetFile $ \h -> do
1578 #if __GLASGOW_HASKELL__ >= 612
1583 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1584 -- to use text files here, rather than binary files.
1585 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1586 withFileAtomic targetFile write_content = do
1587 (newFile, newHandle) <- openNewFile targetDir template
1588 do write_content newHandle
1590 #if mingw32_HOST_OS || mingw32_TARGET_OS
1591 renameFile newFile targetFile
1592 -- If the targetFile exists then renameFile will fail
1593 `catchIO` \err -> do
1594 exists <- doesFileExist targetFile
1596 then do removeFile targetFile
1597 -- Big fat hairy race condition
1598 renameFile newFile targetFile
1599 -- If the removeFile succeeds and the renameFile fails
1600 -- then we've lost the atomic property.
1603 renameFile newFile targetFile
1605 `Exception.onException` do hClose newHandle
1608 template = targetName <.> "tmp"
1609 targetDir | null targetDir_ = "."
1610 | otherwise = targetDir_
1611 --TODO: remove this when takeDirectory/splitFileName is fixed
1612 -- to always return a valid dir
1613 (targetDir_,targetName) = splitFileName targetFile
1615 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1616 openNewFile dir template = do
1617 #if __GLASGOW_HASKELL__ >= 612
1618 -- this was added to System.IO in 6.12.1
1619 -- we must use this version because the version below opens the file
1621 openTempFileWithDefaultPermissions dir template
1623 -- Ugh, this is a copy/paste of code from the base library, but
1624 -- if uses 666 rather than 600 for the permissions.
1628 -- We split off the last extension, so we can use .foo.ext files
1629 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1630 -- below filepath in the hierarchy here.
1632 case break (== '.') $ reverse template of
1633 -- First case: template contains no '.'s. Just re-reverse it.
1634 (rev_suffix, "") -> (reverse rev_suffix, "")
1635 -- Second case: template contains at least one '.'. Strip the
1636 -- dot from the prefix and prepend it to the suffix (if we don't
1637 -- do this, the unique number will get added after the '.' and
1638 -- thus be part of the extension, which is wrong.)
1639 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1640 -- Otherwise, something is wrong, because (break (== '.')) should
1641 -- always return a pair with either the empty string or a string
1642 -- beginning with '.' as the second component.
1643 _ -> error "bug in System.IO.openTempFile"
1645 oflags = rw_flags .|. o_EXCL
1647 #if __GLASGOW_HASKELL__ < 611
1648 withFilePath = withCString
1652 fd <- withFilePath filepath $ \ f ->
1653 c_open f oflags 0o666
1658 then findTempName (x+1)
1659 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1661 -- XXX We want to tell fdToHandle what the filepath is,
1662 -- as any exceptions etc will only be able to report the
1666 `Exception.onException` c_close fd
1667 return (filepath, h)
1669 filename = prefix ++ show x ++ suffix
1670 filepath = dir `combine` filename
1672 -- XXX Copied from GHC.Handle
1673 std_flags, output_flags, rw_flags :: CInt
1674 std_flags = o_NONBLOCK .|. o_NOCTTY
1675 output_flags = std_flags .|. o_CREAT
1676 rw_flags = output_flags .|. o_RDWR
1677 #endif /* GLASGOW_HASKELL < 612 */
1679 -- | The function splits the given string to substrings
1680 -- using 'isSearchPathSeparator'.
1681 parseSearchPath :: String -> [FilePath]
1682 parseSearchPath path = split path
1684 split :: String -> [String]
1688 _:rest -> chunk : split rest
1692 #ifdef mingw32_HOST_OS
1693 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1697 (chunk', rest') = break isSearchPathSeparator s
1699 readUTF8File :: FilePath -> IO String
1700 readUTF8File file = do
1701 h <- openFile file ReadMode
1702 #if __GLASGOW_HASKELL__ >= 612
1703 -- fix the encoding to UTF-8