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 import System.Console.GetOpt
31 import qualified Control.Exception as Exception
34 import Data.Char ( isSpace, toLower )
36 import System.Directory ( doesDirectoryExist, getDirectoryContents,
37 doesFileExist, renameFile, removeFile )
38 import System.Exit ( exitWith, ExitCode(..) )
39 import System.Environment ( getArgs, getProgName, getEnv )
41 import System.IO.Error (try, isDoesNotExistError)
43 import Control.Concurrent
45 import qualified Data.ByteString.Lazy as B
46 import qualified Data.Binary as Bin
47 import qualified Data.Binary.Get as Bin
49 #if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS)
50 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
55 #if __GLASGOW_HASKELL__ < 612
56 import System.Posix.Internals
57 import GHC.Handle (fdToHandle)
60 #ifdef mingw32_HOST_OS
61 import GHC.ConsoleHandler
63 import System.Posix hiding (fdToHandle)
66 import IO ( isPermissionError )
69 import System.Process(runInteractiveCommand)
70 import qualified System.Info(os)
73 #if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
74 import System.Console.Terminfo as Terminfo
77 -- -----------------------------------------------------------------------------
84 case getOpt Permute (flags ++ deprecFlags) args of
85 (cli,_,[]) | FlagHelp `elem` cli -> do
86 prog <- getProgramName
87 bye (usageInfo (usageHeader prog) flags)
88 (cli,_,[]) | FlagVersion `elem` cli ->
91 case getVerbosity Normal cli of
92 Right v -> runit v cli nonopts
95 prog <- getProgramName
96 die (concat errors ++ usageInfo (usageHeader prog) flags)
98 -- -----------------------------------------------------------------------------
99 -- Command-line syntax
106 | FlagConfig FilePath
107 | FlagGlobalConfig FilePath
115 | FlagVerbosity (Maybe String)
118 flags :: [OptDescr Flag]
120 Option [] ["user"] (NoArg FlagUser)
121 "use the current user's package database",
122 Option [] ["global"] (NoArg FlagGlobal)
123 "use the global package database",
124 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
125 "use the specified package config file",
126 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
127 "location of the global package config",
128 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
129 "never read the user package database",
130 Option [] ["force"] (NoArg FlagForce)
131 "ignore missing dependencies, directories, and libraries",
132 Option [] ["force-files"] (NoArg FlagForceFiles)
133 "ignore missing directories and libraries only",
134 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
135 "automatically build libs for GHCi (with register)",
136 Option ['?'] ["help"] (NoArg FlagHelp)
137 "display this help and exit",
138 Option ['V'] ["version"] (NoArg FlagVersion)
139 "output version information and exit",
140 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
141 "print output in easy-to-parse format for some commands",
142 Option [] ["names-only"] (NoArg FlagNamesOnly)
143 "only print package names, not versions; can only be used with list --simple-output",
144 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
145 "ignore case for substring matching",
146 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
147 "verbosity level (0-2, default 1)"
150 data Verbosity = Silent | Normal | Verbose
151 deriving (Show, Eq, Ord)
153 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
154 getVerbosity v [] = Right v
155 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
156 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
157 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
158 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
159 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
160 getVerbosity v (_ : fs) = getVerbosity v fs
162 deprecFlags :: [OptDescr Flag]
164 -- put deprecated flags here
167 ourCopyright :: String
168 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
170 usageHeader :: String -> String
171 usageHeader prog = substProg prog $
173 " $p init {path}\n" ++
174 " Create and initialise a package database at the location {path}.\n" ++
175 " Packages can be registered in the new database using the register\n" ++
176 " command with --package-conf={path}. To use the new database with GHC,\n" ++
177 " use GHC's -package-conf flag.\n" ++
179 " $p register {filename | -}\n" ++
180 " Register the package using the specified installed package\n" ++
181 " description. The syntax for the latter is given in the $p\n" ++
182 " documentation. The input file should be encoded in UTF-8.\n" ++
184 " $p update {filename | -}\n" ++
185 " Register the package, overwriting any other package with the\n" ++
186 " same name. The input file should be encoded in UTF-8.\n" ++
188 " $p unregister {pkg-id}\n" ++
189 " Unregister the specified package.\n" ++
191 " $p expose {pkg-id}\n" ++
192 " Expose the specified package.\n" ++
194 " $p hide {pkg-id}\n" ++
195 " Hide the specified package.\n" ++
197 " $p list [pkg]\n" ++
198 " List registered packages in the global database, and also the\n" ++
199 " user database if --user is given. If a package name is given\n" ++
200 " all the registered versions will be listed in ascending order.\n" ++
201 " Accepts the --simple-output flag.\n" ++
204 " Generate a graph of the package dependencies in a form suitable\n" ++
205 " for input for the graphviz tools. For example, to generate a PDF" ++
206 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
208 " $p find-module {module}\n" ++
209 " List registered packages exposing module {module} in the global\n" ++
210 " database, and also the user database if --user is given.\n" ++
211 " All the registered versions will be listed in ascending order.\n" ++
212 " Accepts the --simple-output flag.\n" ++
214 " $p latest {pkg-id}\n" ++
215 " Prints the highest registered version of a package.\n" ++
218 " Check the consistency of package depenencies and list broken packages.\n" ++
219 " Accepts the --simple-output flag.\n" ++
221 " $p describe {pkg}\n" ++
222 " Give the registered description for the specified package. The\n" ++
223 " description is returned in precisely the syntax required by $p\n" ++
226 " $p field {pkg} {field}\n" ++
227 " Extract the specified field of the package description for the\n" ++
228 " specified package. Accepts comma-separated multiple fields.\n" ++
231 " Dump the registered description for every package. This is like\n" ++
232 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
233 " by tools that parse the results, rather than humans. The output is\n" ++
234 " always encoded in UTF-8, regardless of the current locale.\n" ++
237 " Regenerate the package database cache. This command should only be\n" ++
238 " necessary if you added a package to the database by dropping a file\n" ++
239 " into the database directory manually. By default, the global DB\n" ++
240 " is recached; to recache a different DB use --user or --package-conf\n" ++
241 " as appropriate.\n" ++
243 " Substring matching is supported for {module} in find-module and\n" ++
244 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
245 " open substring ends (prefix*, *suffix, *infix*).\n" ++
247 " When asked to modify a database (register, unregister, update,\n"++
248 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
249 " default. Specifying --user causes it to act on the user database,\n"++
250 " or --package-conf can be used to act on another database\n"++
251 " entirely. When multiple of these options are given, the rightmost\n"++
252 " one is used as the database to act upon.\n"++
254 " Commands that query the package database (list, tree, latest, describe,\n"++
255 " field) operate on the list of databases specified by the flags\n"++
256 " --user, --global, and --package-conf. If none of these flags are\n"++
257 " given, the default is --global --user.\n"++
259 " The following optional flags are also accepted:\n"
261 substProg :: String -> String -> String
263 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
264 substProg prog (c:xs) = c : substProg prog xs
266 -- -----------------------------------------------------------------------------
269 data Force = NoForce | ForceFiles | ForceAll | CannotForce
272 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
274 runit :: Verbosity -> [Flag] -> [String] -> IO ()
275 runit verbosity cli nonopts = do
276 installSignalHandlers -- catch ^C and clean up
277 prog <- getProgramName
280 | FlagForce `elem` cli = ForceAll
281 | FlagForceFiles `elem` cli = ForceFiles
282 | otherwise = NoForce
283 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
284 splitFields fields = unfoldr splitComma (',':fields)
285 where splitComma "" = Nothing
286 splitComma fs = Just $ break (==',') (tail fs)
288 substringCheck :: String -> Maybe (String -> Bool)
289 substringCheck "" = Nothing
290 substringCheck "*" = Just (const True)
291 substringCheck [_] = Nothing
292 substringCheck (h:t) =
293 case (h, init t, last t) of
294 ('*',s,'*') -> Just (isInfixOf (f s) . f)
295 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
296 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
298 where f | FlagIgnoreCase `elem` cli = map toLower
301 glob x | System.Info.os=="mingw32" = do
302 -- glob echoes its argument, after win32 filename globbing
303 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
304 txt <- hGetContents o
306 glob x | otherwise = return [x]
309 -- first, parse the command
312 -- dummy command to demonstrate usage and permit testing
313 -- without messing things up; use glob to selectively enable
314 -- windows filename globbing for file parameters
315 -- register, update, FlagGlobalConfig, FlagConfig; others?
316 ["glob", filename] -> do
318 glob filename >>= print
320 ["init", filename] ->
321 initPackageDB filename verbosity cli
322 ["register", filename] ->
323 registerPackage filename verbosity cli auto_ghci_libs False force
324 ["update", filename] ->
325 registerPackage filename verbosity cli auto_ghci_libs True force
326 ["unregister", pkgid_str] -> do
327 pkgid <- readGlobPkgId pkgid_str
328 unregisterPackage pkgid verbosity cli force
329 ["expose", pkgid_str] -> do
330 pkgid <- readGlobPkgId pkgid_str
331 exposePackage pkgid verbosity cli force
332 ["hide", pkgid_str] -> do
333 pkgid <- readGlobPkgId pkgid_str
334 hidePackage pkgid verbosity cli force
336 listPackages verbosity cli Nothing Nothing
337 ["list", pkgid_str] ->
338 case substringCheck pkgid_str of
339 Nothing -> do pkgid <- readGlobPkgId pkgid_str
340 listPackages verbosity cli (Just (Id pkgid)) Nothing
341 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
343 showPackageDot verbosity cli
344 ["find-module", moduleName] -> do
345 let match = maybe (==moduleName) id (substringCheck moduleName)
346 listPackages verbosity cli Nothing (Just match)
347 ["latest", pkgid_str] -> do
348 pkgid <- readGlobPkgId pkgid_str
349 latestPackage verbosity cli pkgid
350 ["describe", pkgid_str] ->
351 case substringCheck pkgid_str of
352 Nothing -> do pkgid <- readGlobPkgId pkgid_str
353 describePackage verbosity cli (Id pkgid)
354 Just m -> describePackage verbosity cli (Substring pkgid_str m)
355 ["field", pkgid_str, fields] ->
356 case substringCheck pkgid_str of
357 Nothing -> do pkgid <- readGlobPkgId pkgid_str
358 describeField verbosity cli (Id pkgid)
360 Just m -> describeField verbosity cli (Substring pkgid_str m)
363 checkConsistency verbosity cli
366 dumpPackages verbosity cli
369 recache verbosity cli
372 die ("missing command\n" ++
373 usageInfo (usageHeader prog) flags)
375 die ("command-line syntax error\n" ++
376 usageInfo (usageHeader prog) flags)
378 parseCheck :: ReadP a a -> String -> String -> IO a
379 parseCheck parser str what =
380 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
382 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
384 readGlobPkgId :: String -> IO PackageIdentifier
385 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
387 parseGlobPackageId :: ReadP r PackageIdentifier
393 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
395 -- globVersion means "all versions"
396 globVersion :: Version
397 globVersion = Version{ versionBranch=[], versionTags=["*"] }
399 -- -----------------------------------------------------------------------------
402 -- Some commands operate on a single database:
403 -- register, unregister, expose, hide
404 -- however these commands also check the union of the available databases
405 -- in order to check consistency. For example, register will check that
406 -- dependencies exist before registering a package.
408 -- Some commands operate on multiple databases, with overlapping semantics:
409 -- list, describe, field
412 = PackageDB { location :: FilePath,
413 packages :: [InstalledPackageInfo] }
415 type PackageDBStack = [PackageDB]
416 -- A stack of package databases. Convention: head is the topmost
419 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
420 allPackagesInStack = concatMap packages
422 getPkgDatabases :: Verbosity
423 -> Bool -- we are modifying, not reading
424 -> Bool -- read caches, if available
426 -> IO (PackageDBStack,
427 -- the real package DB stack: [global,user] ++
428 -- DBs specified on the command line with -f.
430 -- which one to modify, if any
432 -- the package DBs specified on the command
433 -- line, or [global,user] otherwise. This
434 -- is used as the list of package DBs for
435 -- commands that just read the DB, such as 'list'.
437 getPkgDatabases verbosity modify use_cache my_flags = do
438 -- first we determine the location of the global package config. On Windows,
439 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
440 -- location is passed to the binary using the --global-config flag by the
442 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
444 case [ f | FlagGlobalConfig f <- my_flags ] of
445 [] -> do mb_dir <- getLibDir
447 Nothing -> die err_msg
449 r <- lookForPackageDBIn dir
451 Nothing -> die ("Can't find package database in " ++ dir)
452 Just path -> return path
453 fs -> return (last fs)
455 let no_user_db = FlagNoUserDb `elem` my_flags
457 -- get the location of the user package database, and create it if necessary
458 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
459 e_appdir <- try $ getAppUserDataDirectory "ghc"
462 if no_user_db then return Nothing else
464 Left _ -> return Nothing
466 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
467 dir = appdir </> subdir
468 r <- lookForPackageDBIn dir
470 Nothing -> return (Just (dir </> "package.conf.d", False))
471 Just f -> return (Just (f, True))
473 -- If the user database doesn't exist, and this command isn't a
474 -- "modify" command, then we won't attempt to create or use it.
476 | Just (user_conf,user_exists) <- mb_user_conf,
477 modify || user_exists = [user_conf, global_conf]
478 | otherwise = [global_conf]
480 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
483 Left _ -> sys_databases
485 | last cs == "" -> init cs ++ sys_databases
487 where cs = parseSearchPath path
489 -- The "global" database is always the one at the bottom of the stack.
490 -- This is the database we modify by default.
491 virt_global_conf = last env_stack
493 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
494 where is_db_flag FlagUser
495 | Just (user_conf, _user_exists) <- mb_user_conf
497 is_db_flag FlagGlobal = Just virt_global_conf
498 is_db_flag (FlagConfig f) = Just f
499 is_db_flag _ = Nothing
501 let flag_db_names | null db_flags = env_stack
502 | otherwise = reverse (nub db_flags)
504 -- For a "modify" command, treat all the databases as
505 -- a stack, where we are modifying the top one, but it
506 -- can refer to packages in databases further down the
509 -- -f flags on the command line add to the database
510 -- stack, unless any of them are present in the stack
512 let final_stack = filter (`notElem` env_stack)
513 [ f | FlagConfig f <- reverse my_flags ]
516 -- the database we actually modify is the one mentioned
517 -- rightmost on the command-line.
519 | not modify = Nothing
520 | null db_flags = Just virt_global_conf
521 | otherwise = Just (last db_flags)
523 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
525 let flag_db_stack = [ db | db_name <- flag_db_names,
526 db <- db_stack, location db == db_name ]
528 return (db_stack, to_modify, flag_db_stack)
531 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
532 lookForPackageDBIn dir = do
533 let path_dir = dir </> "package.conf.d"
534 exists_dir <- doesDirectoryExist path_dir
535 if exists_dir then return (Just path_dir) else do
536 let path_file = dir </> "package.conf"
537 exists_file <- doesFileExist path_file
538 if exists_file then return (Just path_file) else return Nothing
540 readParseDatabase :: Verbosity
541 -> Maybe (FilePath,Bool)
546 readParseDatabase verbosity mb_user_conf use_cache path
547 -- the user database (only) is allowed to be non-existent
548 | Just (user_conf,False) <- mb_user_conf, path == user_conf
549 = return PackageDB { location = path, packages = [] }
551 = do e <- try $ getDirectoryContents path
554 pkgs <- parseMultiPackageConf verbosity path
555 return PackageDB{ location = path, packages = pkgs }
557 | not use_cache -> ignore_cache
559 let cache = path </> cachefilename
560 tdir <- getModificationTime path
561 e_tcache <- try $ getModificationTime cache
564 when (verbosity > Normal) $
565 warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
568 | tcache >= tdir -> do
569 when (verbosity > Normal) $
570 putStrLn ("using cache: " ++ cache)
571 pkgs <- myReadBinPackageDB cache
572 let pkgs' = map convertPackageInfoIn pkgs
573 return PackageDB { location = path, packages = pkgs' }
575 when (verbosity >= Normal) $ do
576 warn ("WARNING: cache is out of date: " ++ cache)
577 warn " use 'ghc-pkg recache' to fix."
581 let confs = filter (".conf" `isSuffixOf`) fs
582 pkgs <- mapM (parseSingletonPackageConf verbosity) $
584 return PackageDB { location = path, packages = pkgs }
586 -- read the package.cache file strictly, to work around a problem with
587 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
588 -- after it has been completely read, leading to a sharing violation
590 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
591 myReadBinPackageDB filepath = do
592 h <- openBinaryFile filepath ReadMode
594 b <- B.hGet h (fromIntegral sz)
596 return $ Bin.runGet Bin.get b
598 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
599 parseMultiPackageConf verbosity file = do
600 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
601 str <- readUTF8File file
602 let pkgs = map convertPackageInfoIn $ read str
603 Exception.evaluate pkgs
605 die ("error while parsing " ++ file ++ ": " ++ show e)
607 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
608 parseSingletonPackageConf verbosity file = do
609 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
610 readUTF8File file >>= parsePackageInfo
612 cachefilename :: FilePath
613 cachefilename = "package.cache"
615 -- -----------------------------------------------------------------------------
616 -- Creating a new package DB
618 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
619 initPackageDB filename verbosity _flags = do
620 let eexist = die ("cannot create: " ++ filename ++ " already exists")
621 b1 <- doesFileExist filename
623 b2 <- doesDirectoryExist filename
625 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
627 -- -----------------------------------------------------------------------------
630 registerPackage :: FilePath
633 -> Bool -- auto_ghci_libs
637 registerPackage input verbosity my_flags auto_ghci_libs update force = do
638 (db_stack, Just to_modify, _flag_dbs) <-
639 getPkgDatabases verbosity True True my_flags
642 db_to_operate_on = my_head "register" $
643 filter ((== to_modify).location) db_stack
648 when (verbosity >= Normal) $
649 putStr "Reading package info from stdin ... "
650 #if __GLASGOW_HASKELL__ >= 612
651 -- fix the encoding to UTF-8, since this is an interchange format
652 hSetEncoding stdin utf8
656 when (verbosity >= Normal) $
657 putStr ("Reading package info from " ++ show f ++ " ... ")
660 expanded <- expandEnvVars s force
662 pkg <- parsePackageInfo expanded
663 when (verbosity >= Normal) $
666 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
667 -- truncate the stack for validation, because we don't allow
668 -- packages lower in the stack to refer to those higher up.
669 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
671 removes = [ RemovePackage p
672 | p <- packages db_to_operate_on,
673 sourcePackageId p == sourcePackageId pkg ]
675 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
679 -> IO InstalledPackageInfo
680 parsePackageInfo str =
681 case parseInstalledPackageInfo str of
682 ParseOk _warns ok -> return ok
683 ParseFailed err -> case locatedErrorMsg err of
684 (Nothing, s) -> die s
685 (Just l, s) -> die (show l ++ ": " ++ s)
687 -- -----------------------------------------------------------------------------
688 -- Making changes to a package database
690 data DBOp = RemovePackage InstalledPackageInfo
691 | AddPackage InstalledPackageInfo
692 | ModifyPackage InstalledPackageInfo
694 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
695 changeDB verbosity cmds db = do
696 let db' = updateInternalDB db cmds
697 isfile <- doesFileExist (location db)
699 then writeNewConfig verbosity (location db') (packages db')
701 createDirectoryIfMissing True (location db)
702 changeDBDir verbosity cmds db'
704 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
705 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
707 do_cmd pkgs (RemovePackage p) =
708 filter ((/= installedPackageId p) . installedPackageId) pkgs
709 do_cmd pkgs (AddPackage p) = p : pkgs
710 do_cmd pkgs (ModifyPackage p) =
711 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
714 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
715 changeDBDir verbosity cmds db = do
717 updateDBCache verbosity db
719 do_cmd (RemovePackage p) = do
720 let file = location db </> display (installedPackageId p) <.> "conf"
721 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
723 do_cmd (AddPackage p) = do
724 let file = location db </> display (installedPackageId p) <.> "conf"
725 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
726 writeFileUtf8Atomic file (showInstalledPackageInfo p)
727 do_cmd (ModifyPackage p) =
728 do_cmd (AddPackage p)
730 updateDBCache :: Verbosity -> PackageDB -> IO ()
731 updateDBCache verbosity db = do
732 let filename = location db </> cachefilename
733 when (verbosity > Normal) $
734 putStrLn ("writing cache " ++ filename)
735 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
737 if isPermissionError e
738 then die (filename ++ ": you don't have permission to modify this file")
741 -- -----------------------------------------------------------------------------
742 -- Exposing, Hiding, Unregistering are all similar
744 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
745 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
747 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
748 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
750 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
751 unregisterPackage = modifyPackage RemovePackage
754 :: (InstalledPackageInfo -> DBOp)
760 modifyPackage fn pkgid verbosity my_flags force = do
761 (db_stack, Just _to_modify, _flag_dbs) <-
762 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
764 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
766 db_name = location db
769 pids = map sourcePackageId ps
771 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
772 new_db = updateInternalDB db cmds
774 old_broken = brokenPackages (allPackagesInStack db_stack)
775 rest_of_stack = filter ((/= db_name) . location) db_stack
776 new_stack = new_db : rest_of_stack
777 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
778 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
780 when (not (null newly_broken)) $
781 dieOrForceAll force ("unregistering " ++ display pkgid ++
782 " would break the following packages: "
783 ++ unwords (map display newly_broken))
785 changeDB verbosity cmds db
787 recache :: Verbosity -> [Flag] -> IO ()
788 recache verbosity my_flags = do
789 (db_stack, Just to_modify, _flag_dbs) <-
790 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
792 db_to_operate_on = my_head "recache" $
793 filter ((== to_modify).location) db_stack
795 changeDB verbosity [] db_to_operate_on
797 -- -----------------------------------------------------------------------------
800 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
801 -> Maybe (String->Bool)
803 listPackages verbosity my_flags mPackageName mModuleName = do
804 let simple_output = FlagSimpleOutput `elem` my_flags
805 (db_stack, _, flag_db_stack) <-
806 getPkgDatabases verbosity False True{-use cache-} my_flags
808 let db_stack_filtered -- if a package is given, filter out all other packages
809 | Just this <- mPackageName =
810 [ db{ packages = filter (this `matchesPkg`) (packages db) }
811 | db <- flag_db_stack ]
812 | Just match <- mModuleName = -- packages which expose mModuleName
813 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
814 | db <- flag_db_stack ]
815 | otherwise = flag_db_stack
818 = [ db{ packages = sort_pkgs (packages db) }
819 | db <- db_stack_filtered ]
820 where sort_pkgs = sortBy cmpPkgIds
821 cmpPkgIds pkg1 pkg2 =
822 case pkgName p1 `compare` pkgName p2 of
825 EQ -> pkgVersion p1 `compare` pkgVersion p2
826 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
828 stack = reverse db_stack_sorted
830 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
832 pkg_map = allPackagesInStack db_stack
833 broken = map sourcePackageId (brokenPackages pkg_map)
835 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
836 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
838 pp_pkgs = map pp_pkg pkg_confs
840 | sourcePackageId p `elem` broken = printf "{%s}" doc
842 | otherwise = printf "(%s)" doc
843 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
846 InstalledPackageId ipid = installedPackageId p
847 pkg = display (sourcePackageId p)
849 show_simple = simplePackageList my_flags . allPackagesInStack
851 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
852 prog <- getProgramName
853 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
855 if simple_output then show_simple stack else do
857 #if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
858 mapM_ show_normal stack
861 show_colour withF db =
862 mconcat $ map (<#> termText "\n") $
863 (termText (location db) :
864 map (termText " " <#>) (map pp_pkg (packages db)))
867 | sourcePackageId p `elem` broken = withF Red doc
869 | otherwise = withF Blue doc
870 where doc | verbosity >= Verbose
871 = termText (printf "%s (%s)" pkg ipid)
875 InstalledPackageId ipid = installedPackageId p
876 pkg = display (sourcePackageId p)
878 is_tty <- hIsTerminalDevice stdout
880 then mapM_ show_normal stack
881 else do tty <- Terminfo.setupTermFromEnv
882 case Terminfo.getCapability tty withForegroundColor of
883 Nothing -> mapM_ show_normal stack
884 Just w -> runTermOutput tty $ mconcat $
885 map (show_colour w) stack
888 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
889 simplePackageList my_flags pkgs = do
890 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
892 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
893 when (not (null pkgs)) $
894 hPutStrLn stdout $ concat $ intersperse " " strs
896 showPackageDot :: Verbosity -> [Flag] -> IO ()
897 showPackageDot verbosity myflags = do
898 (_, _, flag_db_stack) <-
899 getPkgDatabases verbosity False True{-use cache-} myflags
901 let all_pkgs = allPackagesInStack flag_db_stack
902 ipix = PackageIndex.fromList all_pkgs
905 let quote s = '"':s ++ "\""
906 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
908 let from = display (sourcePackageId p),
910 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
911 let to = display (sourcePackageId dep)
915 -- -----------------------------------------------------------------------------
916 -- Prints the highest (hidden or exposed) version of a package
918 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
919 latestPackage verbosity my_flags pkgid = do
920 (_, _, flag_db_stack) <-
921 getPkgDatabases verbosity False True{-use cache-} my_flags
923 ps <- findPackages flag_db_stack (Id pkgid)
924 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
926 show_pkg [] = die "no matches"
927 show_pkg pids = hPutStrLn stdout (display (last pids))
929 -- -----------------------------------------------------------------------------
932 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
933 describePackage verbosity my_flags pkgarg = do
934 (_, _, flag_db_stack) <-
935 getPkgDatabases verbosity False True{-use cache-} my_flags
936 ps <- findPackages flag_db_stack pkgarg
939 dumpPackages :: Verbosity -> [Flag] -> IO ()
940 dumpPackages verbosity my_flags = do
941 (_, _, flag_db_stack) <-
942 getPkgDatabases verbosity False True{-use cache-} my_flags
943 doDump (allPackagesInStack flag_db_stack)
945 doDump :: [InstalledPackageInfo] -> IO ()
947 #if __GLASGOW_HASKELL__ >= 612
948 -- fix the encoding to UTF-8, since this is an interchange format
949 hSetEncoding stdout utf8
951 mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
953 -- PackageId is can have globVersion for the version
954 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
955 findPackages db_stack pkgarg
956 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
958 findPackagesByDB :: PackageDBStack -> PackageArg
959 -> IO [(PackageDB, [InstalledPackageInfo])]
960 findPackagesByDB db_stack pkgarg
961 = case [ (db, matched)
963 let matched = filter (pkgarg `matchesPkg`) (packages db),
964 not (null matched) ] of
965 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
968 pkg_msg (Id pkgid) = display pkgid
969 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
971 matches :: PackageIdentifier -> PackageIdentifier -> Bool
973 = (pkgName pid == pkgName pid')
974 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
976 realVersion :: PackageIdentifier -> Bool
977 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
978 -- when versionBranch == [], this is a glob
980 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
981 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
982 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
984 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
985 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
987 -- -----------------------------------------------------------------------------
990 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
991 describeField verbosity my_flags pkgarg fields = do
992 (_, _, flag_db_stack) <-
993 getPkgDatabases verbosity False True{-use cache-} my_flags
994 fns <- toFields fields
995 ps <- findPackages flag_db_stack pkgarg
996 let top_dir = takeDirectory (location (last flag_db_stack))
997 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
998 where toFields [] = return []
999 toFields (f:fs) = case toField f of
1000 Nothing -> die ("unknown field: " ++ f)
1001 Just fn -> do fns <- toFields fs
1003 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1005 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1006 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1007 -- with the current topdir (obtained from the -B option).
1008 mungePackagePaths top_dir ps = map munge_pkg ps
1010 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
1011 includeDirs = munge_paths (includeDirs p),
1012 libraryDirs = munge_paths (libraryDirs p),
1013 frameworkDirs = munge_paths (frameworkDirs p),
1014 haddockInterfaces = munge_paths (haddockInterfaces p),
1015 haddockHTMLs = munge_paths (haddockHTMLs p)
1018 munge_paths = map munge_path
1021 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1022 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1025 toHttpPath p = "file:///" ++ p
1027 maybePrefixMatch :: String -> String -> Maybe String
1028 maybePrefixMatch [] rest = Just rest
1029 maybePrefixMatch (_:_) [] = Nothing
1030 maybePrefixMatch (p:pat) (r:rest)
1031 | p == r = maybePrefixMatch pat rest
1032 | otherwise = Nothing
1034 toField :: String -> Maybe (InstalledPackageInfo -> String)
1035 -- backwards compatibility:
1036 toField "import_dirs" = Just $ strList . importDirs
1037 toField "source_dirs" = Just $ strList . importDirs
1038 toField "library_dirs" = Just $ strList . libraryDirs
1039 toField "hs_libraries" = Just $ strList . hsLibraries
1040 toField "extra_libraries" = Just $ strList . extraLibraries
1041 toField "include_dirs" = Just $ strList . includeDirs
1042 toField "c_includes" = Just $ strList . includes
1043 toField "package_deps" = Just $ strList . map display. depends
1044 toField "extra_cc_opts" = Just $ strList . ccOptions
1045 toField "extra_ld_opts" = Just $ strList . ldOptions
1046 toField "framework_dirs" = Just $ strList . frameworkDirs
1047 toField "extra_frameworks"= Just $ strList . frameworks
1048 toField s = showInstalledPackageInfoField s
1050 strList :: [String] -> String
1054 -- -----------------------------------------------------------------------------
1055 -- Check: Check consistency of installed packages
1057 checkConsistency :: Verbosity -> [Flag] -> IO ()
1058 checkConsistency verbosity my_flags = do
1059 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1060 -- check behaves like modify for the purposes of deciding which
1061 -- databases to use, because ordering is important.
1063 let simple_output = FlagSimpleOutput `elem` my_flags
1065 let pkgs = allPackagesInStack db_stack
1068 (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1070 then do when (not simple_output) $ do
1071 _ <- reportValidateErrors [] ws "" Nothing
1075 when (not simple_output) $ do
1076 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1077 _ <- reportValidateErrors es ws " " Nothing
1081 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1083 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1084 where not_in p = sourcePackageId p `notElem` all_ps
1085 all_ps = map sourcePackageId pkgs1
1087 let not_broken_pkgs = filterOut broken_pkgs pkgs
1088 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1089 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1091 when (not (null all_broken_pkgs)) $ do
1093 then simplePackageList my_flags all_broken_pkgs
1095 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1096 "listed above, or because they depend on a broken package.")
1097 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1099 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1102 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1103 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1104 closure pkgs db_stack = go pkgs db_stack
1106 go avail not_avail =
1107 case partition (depsAvailable avail) not_avail of
1108 ([], not_avail') -> (avail, not_avail')
1109 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1111 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1113 depsAvailable pkgs_ok pkg = null dangling
1114 where dangling = filter (`notElem` pids) (depends pkg)
1115 pids = map installedPackageId pkgs_ok
1117 -- we want mutually recursive groups of package to show up
1118 -- as broken. (#1750)
1120 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1121 brokenPackages pkgs = snd (closure [] pkgs)
1123 -- -----------------------------------------------------------------------------
1124 -- Manipulating package.conf files
1126 type InstalledPackageInfoString = InstalledPackageInfo_ String
1128 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1129 convertPackageInfoOut
1130 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1131 hiddenModules = h })) =
1132 pkgconf{ exposedModules = map display e,
1133 hiddenModules = map display h }
1135 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1136 convertPackageInfoIn
1137 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1138 hiddenModules = h })) =
1139 pkgconf{ exposedModules = map convert e,
1140 hiddenModules = map convert h }
1141 where convert = fromJust . simpleParse
1143 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1144 writeNewConfig verbosity filename ipis = do
1145 when (verbosity >= Normal) $
1146 hPutStr stdout "Writing new package config file... "
1147 createDirectoryIfMissing True $ takeDirectory filename
1148 let shown = concat $ intersperse ",\n "
1149 $ map (show . convertPackageInfoOut) ipis
1150 fileContents = "[" ++ shown ++ "\n]"
1151 writeFileUtf8Atomic filename fileContents
1153 if isPermissionError e
1154 then die (filename ++ ": you don't have permission to modify this file")
1156 when (verbosity >= Normal) $
1157 hPutStrLn stdout "done."
1159 -----------------------------------------------------------------------------
1160 -- Sanity-check a new package config, and automatically build GHCi libs
1163 type ValidateError = (Force,String)
1164 type ValidateWarning = String
1166 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1168 instance Monad Validate where
1169 return a = V $ return (a, [], [])
1171 (a, es, ws) <- runValidate m
1172 (b, es', ws') <- runValidate (k a)
1173 return (b,es++es',ws++ws')
1175 verror :: Force -> String -> Validate ()
1176 verror f s = V (return ((),[(f,s)],[]))
1178 vwarn :: String -> Validate ()
1179 vwarn s = V (return ((),[],["Warning: " ++ s]))
1181 liftIO :: IO a -> Validate a
1182 liftIO k = V (k >>= \a -> return (a,[],[]))
1184 -- returns False if we should die
1185 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1186 -> String -> Maybe Force -> IO Bool
1187 reportValidateErrors es ws prefix mb_force = do
1188 mapM_ (warn . (prefix++)) ws
1189 oks <- mapM report es
1193 | Just force <- mb_force
1195 then do reportError (prefix ++ s ++ " (ignoring)")
1197 else if f < CannotForce
1198 then do reportError (prefix ++ s ++ " (use --force to override)")
1200 else do reportError err
1202 | otherwise = do reportError err
1207 validatePackageConfig :: InstalledPackageInfo
1209 -> Bool -- auto-ghc-libs
1210 -> Bool -- update, or check
1213 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1214 (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1215 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1216 when (not ok) $ exitWith (ExitFailure 1)
1218 checkPackageConfig :: InstalledPackageInfo
1220 -> Bool -- auto-ghc-libs
1221 -> Bool -- update, or check
1223 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1224 checkInstalledPackageId pkg db_stack update
1226 checkDuplicates db_stack pkg update
1227 mapM_ (checkDep db_stack) (depends pkg)
1228 checkDuplicateDepends (depends pkg)
1229 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1230 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1231 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1233 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1234 -- ToDo: check these somehow?
1235 -- extra_libraries :: [String],
1236 -- c_includes :: [String],
1238 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1240 checkInstalledPackageId ipi db_stack update = do
1241 let ipid@(InstalledPackageId str) = installedPackageId ipi
1242 when (null str) $ verror CannotForce "missing id field"
1243 let dups = [ p | p <- allPackagesInStack db_stack,
1244 installedPackageId p == ipid ]
1245 when (not update && not (null dups)) $
1246 verror CannotForce $
1247 "package(s) with this id already exist: " ++
1248 unwords (map (display.packageId) dups)
1250 -- When the package name and version are put together, sometimes we can
1251 -- end up with a package id that cannot be parsed. This will lead to
1252 -- difficulties when the user wants to refer to the package later, so
1253 -- we check that the package id can be parsed properly here.
1254 checkPackageId :: InstalledPackageInfo -> Validate ()
1255 checkPackageId ipi =
1256 let str = display (sourcePackageId ipi) in
1257 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1259 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1260 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1262 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1263 checkDuplicates db_stack pkg update = do
1265 pkgid = sourcePackageId pkg
1266 pkgs = packages (head db_stack)
1268 -- Check whether this package id already exists in this DB
1270 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1271 verror CannotForce $
1272 "package " ++ display pkgid ++ " is already installed"
1275 uncasep = map toLower . display
1276 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1278 when (not update && not (null dups)) $ verror ForceAll $
1279 "Package names may be treated case-insensitively in the future.\n"++
1280 "Package " ++ display pkgid ++
1281 " overlaps with: " ++ unwords (map display dups)
1284 checkDir :: Bool -> String -> String -> Validate ()
1285 checkDir warn_only thisfield d
1286 | "$topdir" `isPrefixOf` d = return ()
1287 | "$httptopdir" `isPrefixOf` d = return ()
1288 -- can't check these, because we don't know what $(http)topdir is
1289 | isRelative d = verror ForceFiles $
1290 thisfield ++ ": " ++ d ++ " is a relative path"
1291 -- relative paths don't make any sense; #4134
1293 there <- liftIO $ doesDirectoryExist d
1295 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
1299 else verror ForceFiles msg
1301 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1302 checkDep db_stack pkgid
1303 | pkgid `elem` pkgids = return ()
1304 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1305 ++ "\" doesn't exist")
1307 all_pkgs = allPackagesInStack db_stack
1308 pkgids = map installedPackageId all_pkgs
1310 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1311 checkDuplicateDepends deps
1312 | null dups = return ()
1313 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1314 unwords (map display dups))
1316 dups = [ p | (p:_:_) <- group (sort deps) ]
1318 checkHSLib :: [String] -> Bool -> String -> Validate ()
1319 checkHSLib dirs auto_ghci_libs lib = do
1320 let batch_lib_file = "lib" ++ lib ++ ".a"
1321 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1323 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1325 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1327 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1328 doesFileExistOnPath file path = go path
1329 where go [] = return Nothing
1330 go (p:ps) = do b <- doesFileExistIn file p
1331 if b then return (Just p) else go ps
1333 doesFileExistIn :: String -> String -> IO Bool
1334 doesFileExistIn lib d
1335 | "$topdir" `isPrefixOf` d = return True
1336 | "$httptopdir" `isPrefixOf` d = return True
1337 | otherwise = doesFileExist (d </> lib)
1339 checkModules :: InstalledPackageInfo -> Validate ()
1340 checkModules pkg = do
1341 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1343 findModule modl = do
1344 -- there's no .hi file for GHC.Prim
1345 if modl == fromString "GHC.Prim" then return () else do
1346 let file = toFilePath modl <.> "hi"
1347 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1348 when (isNothing m) $
1349 verror ForceFiles ("file " ++ file ++ " is missing")
1351 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1352 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1353 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1355 m <- doesFileExistOnPath ghci_lib_file dirs
1356 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1357 warn ("warning: can't find GHCi lib " ++ ghci_lib_file)
1359 ghci_lib_file = lib <.> "o"
1361 -- automatically build the GHCi version of a batch lib,
1362 -- using ld --whole-archive.
1364 autoBuildGHCiLib :: String -> String -> String -> IO ()
1365 autoBuildGHCiLib dir batch_file ghci_file = do
1366 let ghci_lib_file = dir ++ '/':ghci_file
1367 batch_lib_file = dir ++ '/':batch_file
1368 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1369 #if defined(darwin_HOST_OS)
1370 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1371 #elif defined(mingw32_HOST_OS)
1372 execDir <- getLibDir
1373 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1375 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1377 when (r /= ExitSuccess) $ exitWith r
1378 hPutStrLn stderr (" done.")
1380 -- -----------------------------------------------------------------------------
1381 -- Searching for modules
1385 findModules :: [FilePath] -> IO [String]
1387 mms <- mapM searchDir paths
1390 searchDir path prefix = do
1391 fs <- getDirectoryEntries path `catch` \_ -> return []
1392 searchEntries path prefix fs
1394 searchEntries path prefix [] = return []
1395 searchEntries path prefix (f:fs)
1396 | looks_like_a_module = do
1397 ms <- searchEntries path prefix fs
1398 return (prefix `joinModule` f : ms)
1399 | looks_like_a_component = do
1400 ms <- searchDir (path </> f) (prefix `joinModule` f)
1401 ms' <- searchEntries path prefix fs
1404 searchEntries path prefix fs
1407 (base,suffix) = splitFileExt f
1408 looks_like_a_module =
1409 suffix `elem` haskell_suffixes &&
1410 all okInModuleName base
1411 looks_like_a_component =
1412 null suffix && all okInModuleName base
1418 -- ---------------------------------------------------------------------------
1419 -- expanding environment variables in the package configuration
1421 expandEnvVars :: String -> Force -> IO String
1422 expandEnvVars str0 force = go str0 ""
1424 go "" acc = return $! reverse acc
1425 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1426 = do value <- lookupEnvVar var
1427 go rest (reverse value ++ acc)
1428 where close c = c == '}' || c == '\n' -- don't span newlines
1432 lookupEnvVar :: String -> IO String
1434 catch (System.Environment.getEnv nm)
1435 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1439 -----------------------------------------------------------------------------
1441 getProgramName :: IO String
1442 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1443 where str `withoutSuffix` suff
1444 | suff `isSuffixOf` str = take (length str - length suff) str
1447 bye :: String -> IO a
1448 bye s = putStr s >> exitWith ExitSuccess
1450 die :: String -> IO a
1453 dieWith :: Int -> String -> IO a
1456 prog <- getProgramName
1457 hPutStrLn stderr (prog ++ ": " ++ s)
1458 exitWith (ExitFailure ec)
1460 dieOrForceAll :: Force -> String -> IO ()
1461 dieOrForceAll ForceAll s = ignoreError s
1462 dieOrForceAll _other s = dieForcible s
1464 warn :: String -> IO ()
1467 ignoreError :: String -> IO ()
1468 ignoreError s = reportError (s ++ " (ignoring)")
1470 reportError :: String -> IO ()
1471 reportError s = do hFlush stdout; hPutStrLn stderr s
1473 dieForcible :: String -> IO ()
1474 dieForcible s = die (s ++ " (use --force to override)")
1476 my_head :: String -> [a] -> a
1477 my_head s [] = error s
1478 my_head _ (x : _) = x
1480 -----------------------------------------
1481 -- Cut and pasted from ghc/compiler/main/SysTools
1483 #if defined(mingw32_HOST_OS)
1484 subst :: Char -> Char -> String -> String
1485 subst a b ls = map (\ x -> if x == a then b else x) ls
1487 unDosifyPath :: FilePath -> FilePath
1488 unDosifyPath xs = subst '\\' '/' xs
1490 getLibDir :: IO (Maybe String)
1491 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1493 -- (getExecDir cmd) returns the directory in which the current
1494 -- executable, which should be called 'cmd', is running
1495 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1496 -- you'll get "/a/b/c" back as the result
1497 getExecDir :: String -> IO (Maybe String)
1499 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1500 where initN n = reverse . drop n . reverse
1501 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1503 getExecPath :: IO (Maybe String)
1505 allocaArray len $ \buf -> do
1506 ret <- getModuleFileName nullPtr buf len
1507 if ret == 0 then return Nothing
1508 else liftM Just $ peekCString buf
1509 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1511 foreign import stdcall unsafe "GetModuleFileNameA"
1512 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1515 getLibDir :: IO (Maybe String)
1516 getLibDir = return Nothing
1519 -----------------------------------------
1520 -- Adapted from ghc/compiler/utils/Panic
1522 installSignalHandlers :: IO ()
1523 installSignalHandlers = do
1524 threadid <- myThreadId
1526 interrupt = Exception.throwTo threadid
1527 (Exception.ErrorCall "interrupted")
1529 #if !defined(mingw32_HOST_OS)
1530 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1531 _ <- installHandler sigINT (Catch interrupt) Nothing
1534 -- GHC 6.3+ has support for console events on Windows
1535 -- NOTE: running GHCi under a bash shell for some reason requires
1536 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1537 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1538 -- why --SDM 17/12/2004
1539 let sig_handler ControlC = interrupt
1540 sig_handler Break = interrupt
1541 sig_handler _ = return ()
1543 _ <- installHandler (Catch sig_handler)
1547 #if mingw32_HOST_OS || mingw32_TARGET_OS
1548 throwIOIO :: Exception.IOException -> IO a
1549 throwIOIO = Exception.throwIO
1551 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1552 catchIO = Exception.catch
1555 catchError :: IO a -> (String -> IO a) -> IO a
1556 catchError io handler = io `Exception.catch` handler'
1557 where handler' (Exception.ErrorCall err) = handler err
1560 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1561 writeBinaryFileAtomic targetFile obj =
1562 withFileAtomic targetFile $ \h -> do
1563 hSetBinaryMode h True
1564 B.hPutStr h (Bin.encode obj)
1566 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1567 writeFileUtf8Atomic targetFile content =
1568 withFileAtomic targetFile $ \h -> do
1569 #if __GLASGOW_HASKELL__ >= 612
1574 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1575 -- to use text files here, rather than binary files.
1576 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1577 withFileAtomic targetFile write_content = do
1578 (newFile, newHandle) <- openNewFile targetDir template
1579 do write_content newHandle
1581 #if mingw32_HOST_OS || mingw32_TARGET_OS
1582 renameFile newFile targetFile
1583 -- If the targetFile exists then renameFile will fail
1584 `catchIO` \err -> do
1585 exists <- doesFileExist targetFile
1587 then do removeFileSafe targetFile
1588 -- Big fat hairy race condition
1589 renameFile newFile targetFile
1590 -- If the removeFile succeeds and the renameFile fails
1591 -- then we've lost the atomic property.
1594 renameFile newFile targetFile
1596 `Exception.onException` do hClose newHandle
1597 removeFileSafe newFile
1599 template = targetName <.> "tmp"
1600 targetDir | null targetDir_ = "."
1601 | otherwise = targetDir_
1602 --TODO: remove this when takeDirectory/splitFileName is fixed
1603 -- to always return a valid dir
1604 (targetDir_,targetName) = splitFileName targetFile
1606 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1607 openNewFile dir template = do
1608 #if __GLASGOW_HASKELL__ >= 612
1609 -- this was added to System.IO in 6.12.1
1610 -- we must use this version because the version below opens the file
1612 openTempFileWithDefaultPermissions dir template
1614 -- Ugh, this is a copy/paste of code from the base library, but
1615 -- if uses 666 rather than 600 for the permissions.
1619 -- We split off the last extension, so we can use .foo.ext files
1620 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1621 -- below filepath in the hierarchy here.
1623 case break (== '.') $ reverse template of
1624 -- First case: template contains no '.'s. Just re-reverse it.
1625 (rev_suffix, "") -> (reverse rev_suffix, "")
1626 -- Second case: template contains at least one '.'. Strip the
1627 -- dot from the prefix and prepend it to the suffix (if we don't
1628 -- do this, the unique number will get added after the '.' and
1629 -- thus be part of the extension, which is wrong.)
1630 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1631 -- Otherwise, something is wrong, because (break (== '.')) should
1632 -- always return a pair with either the empty string or a string
1633 -- beginning with '.' as the second component.
1634 _ -> error "bug in System.IO.openTempFile"
1636 oflags = rw_flags .|. o_EXCL
1638 withFilePath = withCString
1641 fd <- withFilePath filepath $ \ f ->
1642 c_open f oflags 0o666
1647 then findTempName (x+1)
1648 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1650 -- XXX We want to tell fdToHandle what the filepath is,
1651 -- as any exceptions etc will only be able to report the
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
1697 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1698 removeFileSafe :: FilePath -> IO ()
1700 removeFile fn `catch` \ e ->
1701 when (not $ isDoesNotExistError e) $ ioError e