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
58 import System.Posix.Internals
59 #if __GLASGOW_HASKELL__ >= 611
60 import GHC.IO.Handle.FD (fdToHandle)
62 import GHC.Handle (fdToHandle)
66 #ifdef mingw32_HOST_OS
67 import GHC.ConsoleHandler
69 import System.Posix hiding (fdToHandle)
72 import IO ( isPermissionError )
75 import System.Process(runInteractiveCommand)
76 import qualified System.Info(os)
79 #if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
80 import System.Console.Terminfo as Terminfo
83 -- -----------------------------------------------------------------------------
90 case getOpt Permute (flags ++ deprecFlags) args of
91 (cli,_,[]) | FlagHelp `elem` cli -> do
92 prog <- getProgramName
93 bye (usageInfo (usageHeader prog) flags)
94 (cli,_,[]) | FlagVersion `elem` cli ->
97 case getVerbosity Normal cli of
98 Right v -> runit v cli nonopts
101 prog <- getProgramName
102 die (concat errors ++ usageInfo (usageHeader prog) flags)
104 -- -----------------------------------------------------------------------------
105 -- Command-line syntax
112 | FlagConfig FilePath
113 | FlagGlobalConfig FilePath
121 | FlagVerbosity (Maybe String)
124 flags :: [OptDescr Flag]
126 Option [] ["user"] (NoArg FlagUser)
127 "use the current user's package database",
128 Option [] ["global"] (NoArg FlagGlobal)
129 "use the global package database",
130 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
131 "use the specified package config file",
132 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
133 "location of the global package config",
134 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
135 "never read the user package database",
136 Option [] ["force"] (NoArg FlagForce)
137 "ignore missing dependencies, directories, and libraries",
138 Option [] ["force-files"] (NoArg FlagForceFiles)
139 "ignore missing directories and libraries only",
140 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
141 "automatically build libs for GHCi (with register)",
142 Option ['?'] ["help"] (NoArg FlagHelp)
143 "display this help and exit",
144 Option ['V'] ["version"] (NoArg FlagVersion)
145 "output version information and exit",
146 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
147 "print output in easy-to-parse format for some commands",
148 Option [] ["names-only"] (NoArg FlagNamesOnly)
149 "only print package names, not versions; can only be used with list --simple-output",
150 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
151 "ignore case for substring matching",
152 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
153 "verbosity level (0-2, default 1)"
156 data Verbosity = Silent | Normal | Verbose
157 deriving (Show, Eq, Ord)
159 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
160 getVerbosity v [] = Right v
161 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
162 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
163 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
164 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
165 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
166 getVerbosity v (_ : fs) = getVerbosity v fs
168 deprecFlags :: [OptDescr Flag]
170 -- put deprecated flags here
173 ourCopyright :: String
174 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
176 usageHeader :: String -> String
177 usageHeader prog = substProg prog $
179 " $p init {path}\n" ++
180 " Create and initialise a package database at the location {path}.\n" ++
181 " Packages can be registered in the new database using the register\n" ++
182 " command with --package-conf={path}. To use the new database with GHC,\n" ++
183 " use GHC's -package-conf flag.\n" ++
185 " $p register {filename | -}\n" ++
186 " Register the package using the specified installed package\n" ++
187 " description. The syntax for the latter is given in the $p\n" ++
188 " documentation. The input file should be encoded in UTF-8.\n" ++
190 " $p update {filename | -}\n" ++
191 " Register the package, overwriting any other package with the\n" ++
192 " same name. The input file should be encoded in UTF-8.\n" ++
194 " $p unregister {pkg-id}\n" ++
195 " Unregister the specified package.\n" ++
197 " $p expose {pkg-id}\n" ++
198 " Expose the specified package.\n" ++
200 " $p hide {pkg-id}\n" ++
201 " Hide the specified package.\n" ++
203 " $p list [pkg]\n" ++
204 " List registered packages in the global database, and also the\n" ++
205 " user database if --user is given. If a package name is given\n" ++
206 " all the registered versions will be listed in ascending order.\n" ++
207 " Accepts the --simple-output flag.\n" ++
210 " Generate a graph of the package dependencies in a form suitable\n" ++
211 " for input for the graphviz tools. For example, to generate a PDF" ++
212 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
214 " $p find-module {module}\n" ++
215 " List registered packages exposing module {module} in the global\n" ++
216 " database, and also the user database if --user is given.\n" ++
217 " All the registered versions will be listed in ascending order.\n" ++
218 " Accepts the --simple-output flag.\n" ++
220 " $p latest {pkg-id}\n" ++
221 " Prints the highest registered version of a package.\n" ++
224 " Check the consistency of package depenencies and list broken packages.\n" ++
225 " Accepts the --simple-output flag.\n" ++
227 " $p describe {pkg}\n" ++
228 " Give the registered description for the specified package. The\n" ++
229 " description is returned in precisely the syntax required by $p\n" ++
232 " $p field {pkg} {field}\n" ++
233 " Extract the specified field of the package description for the\n" ++
234 " specified package. Accepts comma-separated multiple fields.\n" ++
237 " Dump the registered description for every package. This is like\n" ++
238 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
239 " by tools that parse the results, rather than humans. The output is\n" ++
240 " always encoded in UTF-8, regardless of the current locale.\n" ++
243 " Regenerate the package database cache. This command should only be\n" ++
244 " necessary if you added a package to the database by dropping a file\n" ++
245 " into the database directory manually. By default, the global DB\n" ++
246 " is recached; to recache a different DB use --user or --package-conf\n" ++
247 " as appropriate.\n" ++
249 " Substring matching is supported for {module} in find-module and\n" ++
250 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
251 " open substring ends (prefix*, *suffix, *infix*).\n" ++
253 " When asked to modify a database (register, unregister, update,\n"++
254 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
255 " default. Specifying --user causes it to act on the user database,\n"++
256 " or --package-conf can be used to act on another database\n"++
257 " entirely. When multiple of these options are given, the rightmost\n"++
258 " one is used as the database to act upon.\n"++
260 " Commands that query the package database (list, tree, latest, describe,\n"++
261 " field) operate on the list of databases specified by the flags\n"++
262 " --user, --global, and --package-conf. If none of these flags are\n"++
263 " given, the default is --global --user.\n"++
265 " The following optional flags are also accepted:\n"
267 substProg :: String -> String -> String
269 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
270 substProg prog (c:xs) = c : substProg prog xs
272 -- -----------------------------------------------------------------------------
275 data Force = NoForce | ForceFiles | ForceAll | CannotForce
278 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
280 runit :: Verbosity -> [Flag] -> [String] -> IO ()
281 runit verbosity cli nonopts = do
282 installSignalHandlers -- catch ^C and clean up
283 prog <- getProgramName
286 | FlagForce `elem` cli = ForceAll
287 | FlagForceFiles `elem` cli = ForceFiles
288 | otherwise = NoForce
289 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
290 splitFields fields = unfoldr splitComma (',':fields)
291 where splitComma "" = Nothing
292 splitComma fs = Just $ break (==',') (tail fs)
294 substringCheck :: String -> Maybe (String -> Bool)
295 substringCheck "" = Nothing
296 substringCheck "*" = Just (const True)
297 substringCheck [_] = Nothing
298 substringCheck (h:t) =
299 case (h, init t, last t) of
300 ('*',s,'*') -> Just (isInfixOf (f s) . f)
301 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
302 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
304 where f | FlagIgnoreCase `elem` cli = map toLower
307 glob x | System.Info.os=="mingw32" = do
308 -- glob echoes its argument, after win32 filename globbing
309 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
310 txt <- hGetContents o
312 glob x | otherwise = return [x]
315 -- first, parse the command
318 -- dummy command to demonstrate usage and permit testing
319 -- without messing things up; use glob to selectively enable
320 -- windows filename globbing for file parameters
321 -- register, update, FlagGlobalConfig, FlagConfig; others?
322 ["glob", filename] -> do
324 glob filename >>= print
326 ["init", filename] ->
327 initPackageDB filename verbosity cli
328 ["register", filename] ->
329 registerPackage filename verbosity cli auto_ghci_libs False force
330 ["update", filename] ->
331 registerPackage filename verbosity cli auto_ghci_libs True force
332 ["unregister", pkgid_str] -> do
333 pkgid <- readGlobPkgId pkgid_str
334 unregisterPackage pkgid verbosity cli force
335 ["expose", pkgid_str] -> do
336 pkgid <- readGlobPkgId pkgid_str
337 exposePackage pkgid verbosity cli force
338 ["hide", pkgid_str] -> do
339 pkgid <- readGlobPkgId pkgid_str
340 hidePackage pkgid verbosity cli force
342 listPackages verbosity cli Nothing Nothing
343 ["list", pkgid_str] ->
344 case substringCheck pkgid_str of
345 Nothing -> do pkgid <- readGlobPkgId pkgid_str
346 listPackages verbosity cli (Just (Id pkgid)) Nothing
347 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
349 showPackageDot verbosity cli
350 ["find-module", moduleName] -> do
351 let match = maybe (==moduleName) id (substringCheck moduleName)
352 listPackages verbosity cli Nothing (Just match)
353 ["latest", pkgid_str] -> do
354 pkgid <- readGlobPkgId pkgid_str
355 latestPackage verbosity cli pkgid
356 ["describe", pkgid_str] ->
357 case substringCheck pkgid_str of
358 Nothing -> do pkgid <- readGlobPkgId pkgid_str
359 describePackage verbosity cli (Id pkgid)
360 Just m -> describePackage verbosity cli (Substring pkgid_str m)
361 ["field", pkgid_str, fields] ->
362 case substringCheck pkgid_str of
363 Nothing -> do pkgid <- readGlobPkgId pkgid_str
364 describeField verbosity cli (Id pkgid)
366 Just m -> describeField verbosity cli (Substring pkgid_str m)
369 checkConsistency verbosity cli
372 dumpPackages verbosity cli
375 recache verbosity cli
378 die ("missing command\n" ++
379 usageInfo (usageHeader prog) flags)
381 die ("command-line syntax error\n" ++
382 usageInfo (usageHeader prog) flags)
384 parseCheck :: ReadP a a -> String -> String -> IO a
385 parseCheck parser str what =
386 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
388 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
390 readGlobPkgId :: String -> IO PackageIdentifier
391 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
393 parseGlobPackageId :: ReadP r PackageIdentifier
399 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
401 -- globVersion means "all versions"
402 globVersion :: Version
403 globVersion = Version{ versionBranch=[], versionTags=["*"] }
405 -- -----------------------------------------------------------------------------
408 -- Some commands operate on a single database:
409 -- register, unregister, expose, hide
410 -- however these commands also check the union of the available databases
411 -- in order to check consistency. For example, register will check that
412 -- dependencies exist before registering a package.
414 -- Some commands operate on multiple databases, with overlapping semantics:
415 -- list, describe, field
418 = PackageDB { location :: FilePath,
419 packages :: [InstalledPackageInfo] }
421 type PackageDBStack = [PackageDB]
422 -- A stack of package databases. Convention: head is the topmost
425 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
426 allPackagesInStack = concatMap packages
428 getPkgDatabases :: Verbosity
429 -> Bool -- we are modifying, not reading
430 -> Bool -- read caches, if available
432 -> IO (PackageDBStack,
433 -- the real package DB stack: [global,user] ++
434 -- DBs specified on the command line with -f.
436 -- which one to modify, if any
438 -- the package DBs specified on the command
439 -- line, or [global,user] otherwise. This
440 -- is used as the list of package DBs for
441 -- commands that just read the DB, such as 'list'.
443 getPkgDatabases verbosity modify use_cache my_flags = do
444 -- first we determine the location of the global package config. On Windows,
445 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
446 -- location is passed to the binary using the --global-config flag by the
448 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
450 case [ f | FlagGlobalConfig f <- my_flags ] of
451 [] -> do mb_dir <- getLibDir
453 Nothing -> die err_msg
455 r <- lookForPackageDBIn dir
457 Nothing -> die ("Can't find package database in " ++ dir)
458 Just path -> return path
459 fs -> return (last fs)
461 let no_user_db = FlagNoUserDb `elem` my_flags
463 -- get the location of the user package database, and create it if necessary
464 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
465 e_appdir <- try $ getAppUserDataDirectory "ghc"
468 if no_user_db then return Nothing else
470 Left _ -> return Nothing
472 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
473 dir = appdir </> subdir
474 r <- lookForPackageDBIn dir
476 Nothing -> return (Just (dir </> "package.conf.d", False))
477 Just f -> return (Just (f, True))
479 -- If the user database doesn't exist, and this command isn't a
480 -- "modify" command, then we won't attempt to create or use it.
482 | Just (user_conf,user_exists) <- mb_user_conf,
483 modify || user_exists = [user_conf, global_conf]
484 | otherwise = [global_conf]
486 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
489 Left _ -> sys_databases
491 | last cs == "" -> init cs ++ sys_databases
493 where cs = parseSearchPath path
495 -- The "global" database is always the one at the bottom of the stack.
496 -- This is the database we modify by default.
497 virt_global_conf = last env_stack
499 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
500 where is_db_flag FlagUser
501 | Just (user_conf, _user_exists) <- mb_user_conf
503 is_db_flag FlagGlobal = Just virt_global_conf
504 is_db_flag (FlagConfig f) = Just f
505 is_db_flag _ = Nothing
507 let flag_db_names | null db_flags = env_stack
508 | otherwise = reverse (nub db_flags)
510 -- For a "modify" command, treat all the databases as
511 -- a stack, where we are modifying the top one, but it
512 -- can refer to packages in databases further down the
515 -- -f flags on the command line add to the database
516 -- stack, unless any of them are present in the stack
518 let final_stack = filter (`notElem` env_stack)
519 [ f | FlagConfig f <- reverse my_flags ]
522 -- the database we actually modify is the one mentioned
523 -- rightmost on the command-line.
525 | not modify = Nothing
526 | null db_flags = Just virt_global_conf
527 | otherwise = Just (last db_flags)
529 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
531 let flag_db_stack = [ db | db_name <- flag_db_names,
532 db <- db_stack, location db == db_name ]
534 return (db_stack, to_modify, flag_db_stack)
537 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
538 lookForPackageDBIn dir = do
539 let path_dir = dir </> "package.conf.d"
540 exists_dir <- doesDirectoryExist path_dir
541 if exists_dir then return (Just path_dir) else do
542 let path_file = dir </> "package.conf"
543 exists_file <- doesFileExist path_file
544 if exists_file then return (Just path_file) else return Nothing
546 readParseDatabase :: Verbosity
547 -> Maybe (FilePath,Bool)
552 readParseDatabase verbosity mb_user_conf use_cache path
553 -- the user database (only) is allowed to be non-existent
554 | Just (user_conf,False) <- mb_user_conf, path == user_conf
555 = return PackageDB { location = path, packages = [] }
557 = do e <- try $ getDirectoryContents path
560 pkgs <- parseMultiPackageConf verbosity path
561 return PackageDB{ location = path, packages = pkgs }
563 | not use_cache -> ignore_cache
565 let cache = path </> cachefilename
566 tdir <- getModificationTime path
567 e_tcache <- try $ getModificationTime cache
570 when (verbosity > Normal) $
571 putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
574 | tcache >= tdir -> do
575 when (verbosity > Normal) $
576 putStrLn ("using cache: " ++ cache)
577 pkgs <- myReadBinPackageDB cache
578 let pkgs' = map convertPackageInfoIn pkgs
579 return PackageDB { location = path, packages = pkgs' }
581 when (verbosity >= Normal) $ do
582 putStrLn ("WARNING: cache is out of date: " ++ cache)
583 putStrLn " use 'ghc-pkg recache' to fix."
587 let confs = filter (".conf" `isSuffixOf`) fs
588 pkgs <- mapM (parseSingletonPackageConf verbosity) $
590 return PackageDB { location = path, packages = pkgs }
592 -- read the package.cache file strictly, to work around a problem with
593 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
594 -- after it has been completely read, leading to a sharing violation
596 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
597 myReadBinPackageDB filepath = do
598 h <- openBinaryFile filepath ReadMode
600 b <- B.hGet h (fromIntegral sz)
602 return $ Bin.runGet Bin.get b
604 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
605 parseMultiPackageConf verbosity file = do
606 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
607 str <- readUTF8File file
608 let pkgs = map convertPackageInfoIn $ read str
609 Exception.evaluate pkgs
611 die ("error while parsing " ++ file ++ ": " ++ show e)
613 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
614 parseSingletonPackageConf verbosity file = do
615 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
616 readUTF8File file >>= parsePackageInfo
618 cachefilename :: FilePath
619 cachefilename = "package.cache"
621 -- -----------------------------------------------------------------------------
622 -- Creating a new package DB
624 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
625 initPackageDB filename verbosity _flags = do
626 let eexist = die ("cannot create: " ++ filename ++ " already exists")
627 b1 <- doesFileExist filename
629 b2 <- doesDirectoryExist filename
631 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
633 -- -----------------------------------------------------------------------------
636 registerPackage :: FilePath
639 -> Bool -- auto_ghci_libs
643 registerPackage input verbosity my_flags auto_ghci_libs update force = do
644 (db_stack, Just to_modify, _flag_dbs) <-
645 getPkgDatabases verbosity True True my_flags
648 db_to_operate_on = my_head "register" $
649 filter ((== to_modify).location) db_stack
654 when (verbosity >= Normal) $
655 putStr "Reading package info from stdin ... "
656 #if __GLASGOW_HASKELL__ >= 612
657 -- fix the encoding to UTF-8, since this is an interchange format
658 hSetEncoding stdin utf8
662 when (verbosity >= Normal) $
663 putStr ("Reading package info from " ++ show f ++ " ... ")
666 expanded <- expandEnvVars s force
668 pkg <- parsePackageInfo expanded
669 when (verbosity >= Normal) $
672 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
673 -- truncate the stack for validation, because we don't allow
674 -- packages lower in the stack to refer to those higher up.
675 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
677 removes = [ RemovePackage p
678 | p <- packages db_to_operate_on,
679 sourcePackageId p == sourcePackageId pkg ]
681 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
685 -> IO InstalledPackageInfo
686 parsePackageInfo str =
687 case parseInstalledPackageInfo str of
688 ParseOk _warns ok -> return ok
689 ParseFailed err -> case locatedErrorMsg err of
690 (Nothing, s) -> die s
691 (Just l, s) -> die (show l ++ ": " ++ s)
693 -- -----------------------------------------------------------------------------
694 -- Making changes to a package database
696 data DBOp = RemovePackage InstalledPackageInfo
697 | AddPackage InstalledPackageInfo
698 | ModifyPackage InstalledPackageInfo
700 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
701 changeDB verbosity cmds db = do
702 let db' = updateInternalDB db cmds
703 isfile <- doesFileExist (location db)
705 then writeNewConfig verbosity (location db') (packages db')
707 createDirectoryIfMissing True (location db)
708 changeDBDir verbosity cmds db'
710 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
711 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
713 do_cmd pkgs (RemovePackage p) =
714 filter ((/= installedPackageId p) . installedPackageId) pkgs
715 do_cmd pkgs (AddPackage p) = p : pkgs
716 do_cmd pkgs (ModifyPackage p) =
717 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
720 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
721 changeDBDir verbosity cmds db = do
723 updateDBCache verbosity db
725 do_cmd (RemovePackage p) = do
726 let file = location db </> display (installedPackageId p) <.> "conf"
727 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
729 do_cmd (AddPackage p) = do
730 let file = location db </> display (installedPackageId p) <.> "conf"
731 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
732 writeFileUtf8Atomic file (showInstalledPackageInfo p)
733 do_cmd (ModifyPackage p) =
734 do_cmd (AddPackage p)
736 updateDBCache :: Verbosity -> PackageDB -> IO ()
737 updateDBCache verbosity db = do
738 let filename = location db </> cachefilename
739 when (verbosity > Normal) $
740 putStrLn ("writing cache " ++ filename)
741 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
743 if isPermissionError e
744 then die (filename ++ ": you don't have permission to modify this file")
747 -- -----------------------------------------------------------------------------
748 -- Exposing, Hiding, Unregistering are all similar
750 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
751 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
753 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
754 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
756 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
757 unregisterPackage = modifyPackage RemovePackage
760 :: (InstalledPackageInfo -> DBOp)
766 modifyPackage fn pkgid verbosity my_flags force = do
767 (db_stack, Just _to_modify, _flag_dbs) <-
768 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
770 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
772 db_name = location db
775 pids = map sourcePackageId ps
777 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
778 new_db = updateInternalDB db cmds
780 old_broken = brokenPackages (allPackagesInStack db_stack)
781 rest_of_stack = filter ((/= db_name) . location) db_stack
782 new_stack = new_db : rest_of_stack
783 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
784 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
786 when (not (null newly_broken)) $
787 dieOrForceAll force ("unregistering " ++ display pkgid ++
788 " would break the following packages: "
789 ++ unwords (map display newly_broken))
791 changeDB verbosity cmds db
793 recache :: Verbosity -> [Flag] -> IO ()
794 recache verbosity my_flags = do
795 (db_stack, Just to_modify, _flag_dbs) <-
796 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
798 db_to_operate_on = my_head "recache" $
799 filter ((== to_modify).location) db_stack
801 changeDB verbosity [] db_to_operate_on
803 -- -----------------------------------------------------------------------------
806 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
807 -> Maybe (String->Bool)
809 listPackages verbosity my_flags mPackageName mModuleName = do
810 let simple_output = FlagSimpleOutput `elem` my_flags
811 (db_stack, _, flag_db_stack) <-
812 getPkgDatabases verbosity False True{-use cache-} my_flags
814 let db_stack_filtered -- if a package is given, filter out all other packages
815 | Just this <- mPackageName =
816 [ db{ packages = filter (this `matchesPkg`) (packages db) }
817 | db <- flag_db_stack ]
818 | Just match <- mModuleName = -- packages which expose mModuleName
819 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
820 | db <- flag_db_stack ]
821 | otherwise = flag_db_stack
824 = [ db{ packages = sort_pkgs (packages db) }
825 | db <- db_stack_filtered ]
826 where sort_pkgs = sortBy cmpPkgIds
827 cmpPkgIds pkg1 pkg2 =
828 case pkgName p1 `compare` pkgName p2 of
831 EQ -> pkgVersion p1 `compare` pkgVersion p2
832 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
834 stack = reverse db_stack_sorted
836 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
838 pkg_map = allPackagesInStack db_stack
839 broken = map sourcePackageId (brokenPackages pkg_map)
841 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
842 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
844 pp_pkgs = map pp_pkg pkg_confs
846 | sourcePackageId p `elem` broken = printf "{%s}" doc
848 | otherwise = printf "(%s)" doc
849 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
852 InstalledPackageId ipid = installedPackageId p
853 pkg = display (sourcePackageId p)
855 show_simple = simplePackageList my_flags . allPackagesInStack
857 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
858 prog <- getProgramName
859 putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
861 if simple_output then show_simple stack else do
863 #if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
864 mapM_ show_normal stack
867 show_colour withF db =
868 mconcat $ map (<#> termText "\n") $
869 (termText (location db) :
870 map (termText " " <#>) (map pp_pkg (packages db)))
873 | sourcePackageId p `elem` broken = withF Red doc
875 | otherwise = withF Blue doc
876 where doc | verbosity >= Verbose
877 = termText (printf "%s (%s)" pkg ipid)
881 InstalledPackageId ipid = installedPackageId p
882 pkg = display (sourcePackageId p)
884 is_tty <- hIsTerminalDevice stdout
886 then mapM_ show_normal stack
887 else do tty <- Terminfo.setupTermFromEnv
888 case Terminfo.getCapability tty withForegroundColor of
889 Nothing -> mapM_ show_normal stack
890 Just w -> runTermOutput tty $ mconcat $
891 map (show_colour w) stack
894 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
895 simplePackageList my_flags pkgs = do
896 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
898 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
899 when (not (null pkgs)) $
900 hPutStrLn stdout $ concat $ intersperse " " strs
902 showPackageDot :: Verbosity -> [Flag] -> IO ()
903 showPackageDot verbosity myflags = do
904 (_, _, flag_db_stack) <-
905 getPkgDatabases verbosity False True{-use cache-} myflags
907 let all_pkgs = allPackagesInStack flag_db_stack
908 ipix = PackageIndex.fromList all_pkgs
911 let quote s = '"':s ++ "\""
912 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
914 let from = display (sourcePackageId p),
916 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
917 let to = display (sourcePackageId dep)
921 -- -----------------------------------------------------------------------------
922 -- Prints the highest (hidden or exposed) version of a package
924 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
925 latestPackage verbosity my_flags pkgid = do
926 (_, _, flag_db_stack) <-
927 getPkgDatabases verbosity False True{-use cache-} my_flags
929 ps <- findPackages flag_db_stack (Id pkgid)
930 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
932 show_pkg [] = die "no matches"
933 show_pkg pids = hPutStrLn stdout (display (last pids))
935 -- -----------------------------------------------------------------------------
938 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
939 describePackage verbosity my_flags pkgarg = do
940 (_, _, flag_db_stack) <-
941 getPkgDatabases verbosity False True{-use cache-} my_flags
942 ps <- findPackages flag_db_stack pkgarg
945 dumpPackages :: Verbosity -> [Flag] -> IO ()
946 dumpPackages verbosity my_flags = do
947 (_, _, flag_db_stack) <-
948 getPkgDatabases verbosity False True{-use cache-} my_flags
949 doDump (allPackagesInStack flag_db_stack)
951 doDump :: [InstalledPackageInfo] -> IO ()
953 #if __GLASGOW_HASKELL__ >= 612
954 -- fix the encoding to UTF-8, since this is an interchange format
955 hSetEncoding stdout utf8
957 mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
959 -- PackageId is can have globVersion for the version
960 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
961 findPackages db_stack pkgarg
962 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
964 findPackagesByDB :: PackageDBStack -> PackageArg
965 -> IO [(PackageDB, [InstalledPackageInfo])]
966 findPackagesByDB db_stack pkgarg
967 = case [ (db, matched)
969 let matched = filter (pkgarg `matchesPkg`) (packages db),
970 not (null matched) ] of
971 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
974 pkg_msg (Id pkgid) = display pkgid
975 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
977 matches :: PackageIdentifier -> PackageIdentifier -> Bool
979 = (pkgName pid == pkgName pid')
980 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
982 realVersion :: PackageIdentifier -> Bool
983 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
984 -- when versionBranch == [], this is a glob
986 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
987 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
988 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
990 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
991 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
993 -- -----------------------------------------------------------------------------
996 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
997 describeField verbosity my_flags pkgarg fields = do
998 (_, _, flag_db_stack) <-
999 getPkgDatabases verbosity False True{-use cache-} my_flags
1000 fns <- toFields fields
1001 ps <- findPackages flag_db_stack pkgarg
1002 let top_dir = takeDirectory (location (last flag_db_stack))
1003 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
1004 where toFields [] = return []
1005 toFields (f:fs) = case toField f of
1006 Nothing -> die ("unknown field: " ++ f)
1007 Just fn -> do fns <- toFields fs
1009 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1011 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1012 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1013 -- with the current topdir (obtained from the -B option).
1014 mungePackagePaths top_dir ps = map munge_pkg ps
1016 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
1017 includeDirs = munge_paths (includeDirs p),
1018 libraryDirs = munge_paths (libraryDirs p),
1019 frameworkDirs = munge_paths (frameworkDirs p),
1020 haddockInterfaces = munge_paths (haddockInterfaces p),
1021 haddockHTMLs = munge_paths (haddockHTMLs p)
1024 munge_paths = map munge_path
1027 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1028 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1031 toHttpPath p = "file:///" ++ p
1033 maybePrefixMatch :: String -> String -> Maybe String
1034 maybePrefixMatch [] rest = Just rest
1035 maybePrefixMatch (_:_) [] = Nothing
1036 maybePrefixMatch (p:pat) (r:rest)
1037 | p == r = maybePrefixMatch pat rest
1038 | otherwise = Nothing
1040 toField :: String -> Maybe (InstalledPackageInfo -> String)
1041 -- backwards compatibility:
1042 toField "import_dirs" = Just $ strList . importDirs
1043 toField "source_dirs" = Just $ strList . importDirs
1044 toField "library_dirs" = Just $ strList . libraryDirs
1045 toField "hs_libraries" = Just $ strList . hsLibraries
1046 toField "extra_libraries" = Just $ strList . extraLibraries
1047 toField "include_dirs" = Just $ strList . includeDirs
1048 toField "c_includes" = Just $ strList . includes
1049 toField "package_deps" = Just $ strList . map display. depends
1050 toField "extra_cc_opts" = Just $ strList . ccOptions
1051 toField "extra_ld_opts" = Just $ strList . ldOptions
1052 toField "framework_dirs" = Just $ strList . frameworkDirs
1053 toField "extra_frameworks"= Just $ strList . frameworks
1054 toField s = showInstalledPackageInfoField s
1056 strList :: [String] -> String
1060 -- -----------------------------------------------------------------------------
1061 -- Check: Check consistency of installed packages
1063 checkConsistency :: Verbosity -> [Flag] -> IO ()
1064 checkConsistency verbosity my_flags = do
1065 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1066 -- check behaves like modify for the purposes of deciding which
1067 -- databases to use, because ordering is important.
1069 let simple_output = FlagSimpleOutput `elem` my_flags
1071 let pkgs = allPackagesInStack db_stack
1074 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
1078 when (not simple_output) $ do
1079 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1080 _ <- reportValidateErrors es " " Nothing
1084 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1086 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1087 where not_in p = sourcePackageId p `notElem` all_ps
1088 all_ps = map sourcePackageId pkgs1
1090 let not_broken_pkgs = filterOut broken_pkgs pkgs
1091 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1092 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1094 when (not (null all_broken_pkgs)) $ do
1096 then simplePackageList my_flags all_broken_pkgs
1098 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1099 "listed above, or because they depend on a broken package.")
1100 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1102 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1105 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1106 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1107 closure pkgs db_stack = go pkgs db_stack
1109 go avail not_avail =
1110 case partition (depsAvailable avail) not_avail of
1111 ([], not_avail') -> (avail, not_avail')
1112 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1114 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1116 depsAvailable pkgs_ok pkg = null dangling
1117 where dangling = filter (`notElem` pids) (depends pkg)
1118 pids = map installedPackageId pkgs_ok
1120 -- we want mutually recursive groups of package to show up
1121 -- as broken. (#1750)
1123 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1124 brokenPackages pkgs = snd (closure [] pkgs)
1126 -- -----------------------------------------------------------------------------
1127 -- Manipulating package.conf files
1129 type InstalledPackageInfoString = InstalledPackageInfo_ String
1131 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1132 convertPackageInfoOut
1133 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1134 hiddenModules = h })) =
1135 pkgconf{ exposedModules = map display e,
1136 hiddenModules = map display h }
1138 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1139 convertPackageInfoIn
1140 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1141 hiddenModules = h })) =
1142 pkgconf{ exposedModules = map convert e,
1143 hiddenModules = map convert h }
1144 where convert = fromJust . simpleParse
1146 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1147 writeNewConfig verbosity filename ipis = do
1148 when (verbosity >= Normal) $
1149 hPutStr stdout "Writing new package config file... "
1150 createDirectoryIfMissing True $ takeDirectory filename
1151 let shown = concat $ intersperse ",\n "
1152 $ map (show . convertPackageInfoOut) ipis
1153 fileContents = "[" ++ shown ++ "\n]"
1154 writeFileUtf8Atomic filename fileContents
1156 if isPermissionError e
1157 then die (filename ++ ": you don't have permission to modify this file")
1159 when (verbosity >= Normal) $
1160 hPutStrLn stdout "done."
1162 -----------------------------------------------------------------------------
1163 -- Sanity-check a new package config, and automatically build GHCi libs
1166 type ValidateError = (Force,String)
1168 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
1170 instance Monad Validate where
1171 return a = V $ return (a, [])
1173 (a, es) <- runValidate m
1174 (b, es') <- runValidate (k a)
1177 verror :: Force -> String -> Validate ()
1178 verror f s = V (return ((),[(f,s)]))
1180 liftIO :: IO a -> Validate a
1181 liftIO k = V (k >>= \a -> return (a,[]))
1183 -- returns False if we should die
1184 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
1185 reportValidateErrors es prefix mb_force = do
1186 oks <- mapM report es
1190 | Just force <- mb_force
1192 then do reportError (prefix ++ s ++ " (ignoring)")
1194 else if f < CannotForce
1195 then do reportError (prefix ++ s ++ " (use --force to override)")
1197 else do reportError err
1199 | otherwise = do reportError err
1204 validatePackageConfig :: InstalledPackageInfo
1206 -> Bool -- auto-ghc-libs
1207 -> Bool -- update, or check
1210 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1211 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1212 ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
1213 when (not ok) $ exitWith (ExitFailure 1)
1215 checkPackageConfig :: InstalledPackageInfo
1217 -> Bool -- auto-ghc-libs
1218 -> Bool -- update, or check
1220 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1221 checkInstalledPackageId pkg db_stack update
1223 checkDuplicates db_stack pkg update
1224 mapM_ (checkDep db_stack) (depends pkg)
1225 checkDuplicateDepends (depends pkg)
1226 mapM_ (checkDir "import-dirs") (importDirs pkg)
1227 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
1228 mapM_ (checkDir "include-dirs") (includeDirs pkg)
1230 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1231 -- ToDo: check these somehow?
1232 -- extra_libraries :: [String],
1233 -- c_includes :: [String],
1235 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1237 checkInstalledPackageId ipi db_stack update = do
1238 let ipid@(InstalledPackageId str) = installedPackageId ipi
1239 when (null str) $ verror CannotForce "missing id field"
1240 let dups = [ p | p <- allPackagesInStack db_stack,
1241 installedPackageId p == ipid ]
1242 when (not update && not (null dups)) $
1243 verror CannotForce $
1244 "package(s) with this id already exist: " ++
1245 unwords (map (display.packageId) dups)
1247 -- When the package name and version are put together, sometimes we can
1248 -- end up with a package id that cannot be parsed. This will lead to
1249 -- difficulties when the user wants to refer to the package later, so
1250 -- we check that the package id can be parsed properly here.
1251 checkPackageId :: InstalledPackageInfo -> Validate ()
1252 checkPackageId ipi =
1253 let str = display (sourcePackageId ipi) in
1254 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1256 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1257 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1259 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1260 checkDuplicates db_stack pkg update = do
1262 pkgid = sourcePackageId pkg
1263 pkgs = packages (head db_stack)
1265 -- Check whether this package id already exists in this DB
1267 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1268 verror CannotForce $
1269 "package " ++ display pkgid ++ " is already installed"
1272 uncasep = map toLower . display
1273 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1275 when (not update && not (null dups)) $ verror ForceAll $
1276 "Package names may be treated case-insensitively in the future.\n"++
1277 "Package " ++ display pkgid ++
1278 " overlaps with: " ++ unwords (map display dups)
1281 checkDir :: String -> String -> Validate ()
1282 checkDir thisfield d
1283 | "$topdir" `isPrefixOf` d = return ()
1284 | "$httptopdir" `isPrefixOf` d = return ()
1285 -- can't check these, because we don't know what $(http)topdir is
1287 there <- liftIO $ doesDirectoryExist d
1289 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1291 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1292 checkDep db_stack pkgid
1293 | pkgid `elem` pkgids = return ()
1294 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1295 ++ "\" doesn't exist")
1297 all_pkgs = allPackagesInStack db_stack
1298 pkgids = map installedPackageId all_pkgs
1300 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1301 checkDuplicateDepends deps
1302 | null dups = return ()
1303 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1304 unwords (map display dups))
1306 dups = [ p | (p:_:_) <- group (sort deps) ]
1308 checkHSLib :: [String] -> Bool -> String -> Validate ()
1309 checkHSLib dirs auto_ghci_libs lib = do
1310 let batch_lib_file = "lib" ++ lib ++ ".a"
1311 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1313 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1315 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1317 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1318 doesFileExistOnPath file path = go path
1319 where go [] = return Nothing
1320 go (p:ps) = do b <- doesFileExistIn file p
1321 if b then return (Just p) else go ps
1323 doesFileExistIn :: String -> String -> IO Bool
1324 doesFileExistIn lib d
1325 | "$topdir" `isPrefixOf` d = return True
1326 | "$httptopdir" `isPrefixOf` d = return True
1327 | otherwise = doesFileExist (d </> lib)
1329 checkModules :: InstalledPackageInfo -> Validate ()
1330 checkModules pkg = do
1331 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1333 findModule modl = do
1334 -- there's no .hi file for GHC.Prim
1335 if modl == fromString "GHC.Prim" then return () else do
1336 let file = toFilePath modl <.> "hi"
1337 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1338 when (isNothing m) $
1339 verror ForceFiles ("file " ++ file ++ " is missing")
1341 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1342 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1343 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1345 m <- doesFileExistOnPath ghci_lib_file dirs
1346 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1347 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1349 ghci_lib_file = lib <.> "o"
1351 -- automatically build the GHCi version of a batch lib,
1352 -- using ld --whole-archive.
1354 autoBuildGHCiLib :: String -> String -> String -> IO ()
1355 autoBuildGHCiLib dir batch_file ghci_file = do
1356 let ghci_lib_file = dir ++ '/':ghci_file
1357 batch_lib_file = dir ++ '/':batch_file
1358 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1359 #if defined(darwin_HOST_OS)
1360 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1361 #elif defined(mingw32_HOST_OS)
1362 execDir <- getLibDir
1363 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1365 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1367 when (r /= ExitSuccess) $ exitWith r
1368 hPutStrLn stderr (" done.")
1370 -- -----------------------------------------------------------------------------
1371 -- Searching for modules
1375 findModules :: [FilePath] -> IO [String]
1377 mms <- mapM searchDir paths
1380 searchDir path prefix = do
1381 fs <- getDirectoryEntries path `catch` \_ -> return []
1382 searchEntries path prefix fs
1384 searchEntries path prefix [] = return []
1385 searchEntries path prefix (f:fs)
1386 | looks_like_a_module = do
1387 ms <- searchEntries path prefix fs
1388 return (prefix `joinModule` f : ms)
1389 | looks_like_a_component = do
1390 ms <- searchDir (path </> f) (prefix `joinModule` f)
1391 ms' <- searchEntries path prefix fs
1394 searchEntries path prefix fs
1397 (base,suffix) = splitFileExt f
1398 looks_like_a_module =
1399 suffix `elem` haskell_suffixes &&
1400 all okInModuleName base
1401 looks_like_a_component =
1402 null suffix && all okInModuleName base
1408 -- ---------------------------------------------------------------------------
1409 -- expanding environment variables in the package configuration
1411 expandEnvVars :: String -> Force -> IO String
1412 expandEnvVars str0 force = go str0 ""
1414 go "" acc = return $! reverse acc
1415 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1416 = do value <- lookupEnvVar var
1417 go rest (reverse value ++ acc)
1418 where close c = c == '}' || c == '\n' -- don't span newlines
1422 lookupEnvVar :: String -> IO String
1424 catch (System.Environment.getEnv nm)
1425 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1429 -----------------------------------------------------------------------------
1431 getProgramName :: IO String
1432 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1433 where str `withoutSuffix` suff
1434 | suff `isSuffixOf` str = take (length str - length suff) str
1437 bye :: String -> IO a
1438 bye s = putStr s >> exitWith ExitSuccess
1440 die :: String -> IO a
1443 dieWith :: Int -> String -> IO a
1446 prog <- getProgramName
1447 hPutStrLn stderr (prog ++ ": " ++ s)
1448 exitWith (ExitFailure ec)
1450 dieOrForceAll :: Force -> String -> IO ()
1451 dieOrForceAll ForceAll s = ignoreError s
1452 dieOrForceAll _other s = dieForcible s
1454 ignoreError :: String -> IO ()
1455 ignoreError s = reportError (s ++ " (ignoring)")
1457 reportError :: String -> IO ()
1458 reportError s = do hFlush stdout; hPutStrLn stderr s
1460 dieForcible :: String -> IO ()
1461 dieForcible s = die (s ++ " (use --force to override)")
1463 my_head :: String -> [a] -> a
1464 my_head s [] = error s
1465 my_head _ (x : _) = x
1467 -----------------------------------------
1468 -- Cut and pasted from ghc/compiler/main/SysTools
1470 #if defined(mingw32_HOST_OS)
1471 subst :: Char -> Char -> String -> String
1472 subst a b ls = map (\ x -> if x == a then b else x) ls
1474 unDosifyPath :: FilePath -> FilePath
1475 unDosifyPath xs = subst '\\' '/' xs
1477 getLibDir :: IO (Maybe String)
1478 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1480 -- (getExecDir cmd) returns the directory in which the current
1481 -- executable, which should be called 'cmd', is running
1482 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1483 -- you'll get "/a/b/c" back as the result
1484 getExecDir :: String -> IO (Maybe String)
1486 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1487 where initN n = reverse . drop n . reverse
1488 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1490 getExecPath :: IO (Maybe String)
1492 allocaArray len $ \buf -> do
1493 ret <- getModuleFileName nullPtr buf len
1494 if ret == 0 then return Nothing
1495 else liftM Just $ peekCString buf
1496 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1498 foreign import stdcall unsafe "GetModuleFileNameA"
1499 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1502 getLibDir :: IO (Maybe String)
1503 getLibDir = return Nothing
1506 -----------------------------------------
1507 -- Adapted from ghc/compiler/utils/Panic
1509 installSignalHandlers :: IO ()
1510 installSignalHandlers = do
1511 threadid <- myThreadId
1513 interrupt = Exception.throwTo threadid
1514 (Exception.ErrorCall "interrupted")
1516 #if !defined(mingw32_HOST_OS)
1517 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1518 _ <- installHandler sigINT (Catch interrupt) Nothing
1520 #elif __GLASGOW_HASKELL__ >= 603
1521 -- GHC 6.3+ has support for console events on Windows
1522 -- NOTE: running GHCi under a bash shell for some reason requires
1523 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1524 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1525 -- why --SDM 17/12/2004
1526 let sig_handler ControlC = interrupt
1527 sig_handler Break = interrupt
1528 sig_handler _ = return ()
1530 _ <- installHandler (Catch sig_handler)
1533 return () -- nothing
1536 #if __GLASGOW_HASKELL__ <= 604
1537 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1538 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1541 #if mingw32_HOST_OS || mingw32_TARGET_OS
1542 throwIOIO :: Exception.IOException -> IO a
1543 throwIOIO = Exception.throwIO
1545 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1546 catchIO = Exception.catch
1549 catchError :: IO a -> (String -> IO a) -> IO a
1550 catchError io handler = io `Exception.catch` handler'
1551 where handler' (Exception.ErrorCall err) = handler err
1554 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1555 writeBinaryFileAtomic targetFile obj =
1556 withFileAtomic targetFile $ \h -> do
1557 hSetBinaryMode h True
1558 B.hPutStr h (Bin.encode obj)
1560 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1561 writeFileUtf8Atomic targetFile content =
1562 withFileAtomic targetFile $ \h -> do
1563 #if __GLASGOW_HASKELL__ >= 612
1568 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1569 -- to use text files here, rather than binary files.
1570 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1571 withFileAtomic targetFile write_content = do
1572 (newFile, newHandle) <- openNewFile targetDir template
1573 do write_content newHandle
1575 #if mingw32_HOST_OS || mingw32_TARGET_OS
1576 renameFile newFile targetFile
1577 -- If the targetFile exists then renameFile will fail
1578 `catchIO` \err -> do
1579 exists <- doesFileExist targetFile
1581 then do removeFile targetFile
1582 -- Big fat hairy race condition
1583 renameFile newFile targetFile
1584 -- If the removeFile succeeds and the renameFile fails
1585 -- then we've lost the atomic property.
1588 renameFile newFile targetFile
1590 `Exception.onException` do hClose newHandle
1593 template = targetName <.> "tmp"
1594 targetDir | null targetDir_ = "."
1595 | otherwise = targetDir_
1596 --TODO: remove this when takeDirectory/splitFileName is fixed
1597 -- to always return a valid dir
1598 (targetDir_,targetName) = splitFileName targetFile
1600 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1601 openNewFile dir template = do
1602 #if __GLASGOW_HASKELL__ >= 612
1603 -- this was added to System.IO in 6.12.1
1604 -- we must use this version because the version below opens the file
1606 openTempFileWithDefaultPermissions dir template
1608 -- Ugh, this is a copy/paste of code from the base library, but
1609 -- if uses 666 rather than 600 for the permissions.
1613 -- We split off the last extension, so we can use .foo.ext files
1614 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1615 -- below filepath in the hierarchy here.
1617 case break (== '.') $ reverse template of
1618 -- First case: template contains no '.'s. Just re-reverse it.
1619 (rev_suffix, "") -> (reverse rev_suffix, "")
1620 -- Second case: template contains at least one '.'. Strip the
1621 -- dot from the prefix and prepend it to the suffix (if we don't
1622 -- do this, the unique number will get added after the '.' and
1623 -- thus be part of the extension, which is wrong.)
1624 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1625 -- Otherwise, something is wrong, because (break (== '.')) should
1626 -- always return a pair with either the empty string or a string
1627 -- beginning with '.' as the second component.
1628 _ -> error "bug in System.IO.openTempFile"
1630 oflags = rw_flags .|. o_EXCL
1632 #if __GLASGOW_HASKELL__ < 611
1633 withFilePath = withCString
1637 fd <- withFilePath filepath $ \ f ->
1638 c_open f oflags 0o666
1643 then findTempName (x+1)
1644 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1646 -- XXX We want to tell fdToHandle what the filepath is,
1647 -- as any exceptions etc will only be able to report the
1650 #if __GLASGOW_HASKELL__ >= 609
1653 fdToHandle (fromIntegral fd)
1655 `Exception.onException` c_close fd
1656 return (filepath, h)
1658 filename = prefix ++ show x ++ suffix
1659 filepath = dir `combine` filename
1661 -- XXX Copied from GHC.Handle
1662 std_flags, output_flags, rw_flags :: CInt
1663 std_flags = o_NONBLOCK .|. o_NOCTTY
1664 output_flags = std_flags .|. o_CREAT
1665 rw_flags = output_flags .|. o_RDWR
1666 #endif /* GLASGOW_HASKELL < 612 */
1668 -- | The function splits the given string to substrings
1669 -- using 'isSearchPathSeparator'.
1670 parseSearchPath :: String -> [FilePath]
1671 parseSearchPath path = split path
1673 split :: String -> [String]
1677 _:rest -> chunk : split rest
1681 #ifdef mingw32_HOST_OS
1682 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1686 (chunk', rest') = break isSearchPathSeparator s
1688 readUTF8File :: FilePath -> IO String
1689 readUTF8File file = do
1690 h <- openFile file ReadMode
1691 #if __GLASGOW_HASKELL__ >= 612
1692 -- fix the encoding to UTF-8