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