1 {-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
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 as FilePath
23 import qualified System.FilePath.Posix as FilePath.Posix
24 import System.Cmd ( rawSystem )
25 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
31 import System.Console.GetOpt
32 import qualified Control.Exception as Exception
35 import Data.Char ( isSpace, toLower )
37 import System.Directory ( doesDirectoryExist, getDirectoryContents,
38 doesFileExist, renameFile, removeFile,
40 import System.Exit ( exitWith, ExitCode(..) )
41 import System.Environment ( getArgs, getProgName, getEnv )
43 import System.IO.Error
45 import Control.Concurrent
47 import qualified Data.ByteString.Lazy as B
48 import qualified Data.Binary as Bin
49 import qualified Data.Binary.Get as Bin
51 #if defined(mingw32_HOST_OS)
52 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
57 #ifdef mingw32_HOST_OS
58 import GHC.ConsoleHandler
60 import System.Posix hiding (fdToHandle)
64 import System.Process(runInteractiveCommand)
65 import qualified System.Info(os)
68 #if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
69 import System.Console.Terminfo as Terminfo
72 -- -----------------------------------------------------------------------------
79 case getOpt Permute (flags ++ deprecFlags) args of
80 (cli,_,[]) | FlagHelp `elem` cli -> do
81 prog <- getProgramName
82 bye (usageInfo (usageHeader prog) flags)
83 (cli,_,[]) | FlagVersion `elem` cli ->
86 case getVerbosity Normal cli of
87 Right v -> runit v cli nonopts
90 prog <- getProgramName
91 die (concat errors ++ usageInfo (usageHeader prog) flags)
93 -- -----------------------------------------------------------------------------
94 -- Command-line syntax
101 | FlagConfig FilePath
102 | FlagGlobalConfig FilePath
108 | FlagNoExpandPkgroot
113 | FlagVerbosity (Maybe String)
116 flags :: [OptDescr Flag]
118 Option [] ["user"] (NoArg FlagUser)
119 "use the current user's package database",
120 Option [] ["global"] (NoArg FlagGlobal)
121 "use the global package database",
122 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
123 "use the specified package config file",
124 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
125 "location of the global package config",
126 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
127 "never read the user package database",
128 Option [] ["force"] (NoArg FlagForce)
129 "ignore missing dependencies, directories, and libraries",
130 Option [] ["force-files"] (NoArg FlagForceFiles)
131 "ignore missing directories and libraries only",
132 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
133 "automatically build libs for GHCi (with register)",
134 Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
135 "expand environment variables (${name}-style) in input package descriptions",
136 Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
137 "expand ${pkgroot}-relative paths to absolute in output package descriptions",
138 Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
139 "preserve ${pkgroot}-relative paths in output package descriptions",
140 Option ['?'] ["help"] (NoArg FlagHelp)
141 "display this help and exit",
142 Option ['V'] ["version"] (NoArg FlagVersion)
143 "output version information and exit",
144 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
145 "print output in easy-to-parse format for some commands",
146 Option [] ["names-only"] (NoArg FlagNamesOnly)
147 "only print package names, not versions; can only be used with list --simple-output",
148 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
149 "ignore case for substring matching",
150 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
151 "verbosity level (0-2, default 1)"
154 data Verbosity = Silent | Normal | Verbose
155 deriving (Show, Eq, Ord)
157 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
158 getVerbosity v [] = Right v
159 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
160 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
161 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
162 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
163 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
164 getVerbosity v (_ : fs) = getVerbosity v fs
166 deprecFlags :: [OptDescr Flag]
168 -- put deprecated flags here
171 ourCopyright :: String
172 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
174 usageHeader :: String -> String
175 usageHeader prog = substProg prog $
177 " $p init {path}\n" ++
178 " Create and initialise a package database at the location {path}.\n" ++
179 " Packages can be registered in the new database using the register\n" ++
180 " command with --package-conf={path}. To use the new database with GHC,\n" ++
181 " use GHC's -package-conf flag.\n" ++
183 " $p register {filename | -}\n" ++
184 " Register the package using the specified installed package\n" ++
185 " description. The syntax for the latter is given in the $p\n" ++
186 " documentation. The input file should be encoded in UTF-8.\n" ++
188 " $p update {filename | -}\n" ++
189 " Register the package, overwriting any other package with the\n" ++
190 " same name. The input file should be encoded in UTF-8.\n" ++
192 " $p unregister {pkg-id}\n" ++
193 " Unregister the specified package.\n" ++
195 " $p expose {pkg-id}\n" ++
196 " Expose the specified package.\n" ++
198 " $p hide {pkg-id}\n" ++
199 " Hide the specified package.\n" ++
201 " $p list [pkg]\n" ++
202 " List registered packages in the global database, and also the\n" ++
203 " user database if --user is given. If a package name is given\n" ++
204 " all the registered versions will be listed in ascending order.\n" ++
205 " Accepts the --simple-output flag.\n" ++
208 " Generate a graph of the package dependencies in a form suitable\n" ++
209 " for input for the graphviz tools. For example, to generate a PDF" ++
210 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
212 " $p find-module {module}\n" ++
213 " List registered packages exposing module {module} in the global\n" ++
214 " database, and also the user database if --user is given.\n" ++
215 " All the registered versions will be listed in ascending order.\n" ++
216 " Accepts the --simple-output flag.\n" ++
218 " $p latest {pkg-id}\n" ++
219 " Prints the highest registered version of a package.\n" ++
222 " Check the consistency of package depenencies and list broken packages.\n" ++
223 " Accepts the --simple-output flag.\n" ++
225 " $p describe {pkg}\n" ++
226 " Give the registered description for the specified package. The\n" ++
227 " description is returned in precisely the syntax required by $p\n" ++
230 " $p field {pkg} {field}\n" ++
231 " Extract the specified field of the package description for the\n" ++
232 " specified package. Accepts comma-separated multiple fields.\n" ++
235 " Dump the registered description for every package. This is like\n" ++
236 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
237 " by tools that parse the results, rather than humans. The output is\n" ++
238 " always encoded in UTF-8, regardless of the current locale.\n" ++
241 " Regenerate the package database cache. This command should only be\n" ++
242 " necessary if you added a package to the database by dropping a file\n" ++
243 " into the database directory manually. By default, the global DB\n" ++
244 " is recached; to recache a different DB use --user or --package-conf\n" ++
245 " as appropriate.\n" ++
247 " Substring matching is supported for {module} in find-module and\n" ++
248 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
249 " open substring ends (prefix*, *suffix, *infix*).\n" ++
251 " When asked to modify a database (register, unregister, update,\n"++
252 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
253 " default. Specifying --user causes it to act on the user database,\n"++
254 " or --package-conf can be used to act on another database\n"++
255 " entirely. When multiple of these options are given, the rightmost\n"++
256 " one is used as the database to act upon.\n"++
258 " Commands that query the package database (list, tree, latest, describe,\n"++
259 " field) operate on the list of databases specified by the flags\n"++
260 " --user, --global, and --package-conf. If none of these flags are\n"++
261 " given, the default is --global --user.\n"++
263 " The following optional flags are also accepted:\n"
265 substProg :: String -> String -> String
267 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
268 substProg prog (c:xs) = c : substProg prog xs
270 -- -----------------------------------------------------------------------------
273 data Force = NoForce | ForceFiles | ForceAll | CannotForce
276 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
278 runit :: Verbosity -> [Flag] -> [String] -> IO ()
279 runit verbosity cli nonopts = do
280 installSignalHandlers -- catch ^C and clean up
281 prog <- getProgramName
284 | FlagForce `elem` cli = ForceAll
285 | FlagForceFiles `elem` cli = ForceFiles
286 | otherwise = NoForce
287 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
288 expand_env_vars= FlagExpandEnvVars `elem` cli
289 mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
290 where accumExpandPkgroot _ FlagExpandPkgroot = Just True
291 accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
292 accumExpandPkgroot x _ = x
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
334 auto_ghci_libs expand_env_vars False force
335 ["update", filename] ->
336 registerPackage filename verbosity cli
337 auto_ghci_libs expand_env_vars True force
338 ["unregister", pkgid_str] -> do
339 pkgid <- readGlobPkgId pkgid_str
340 unregisterPackage pkgid verbosity cli force
341 ["expose", pkgid_str] -> do
342 pkgid <- readGlobPkgId pkgid_str
343 exposePackage pkgid verbosity cli force
344 ["hide", pkgid_str] -> do
345 pkgid <- readGlobPkgId pkgid_str
346 hidePackage pkgid verbosity cli force
348 listPackages verbosity cli Nothing Nothing
349 ["list", pkgid_str] ->
350 case substringCheck pkgid_str of
351 Nothing -> do pkgid <- readGlobPkgId pkgid_str
352 listPackages verbosity cli (Just (Id pkgid)) Nothing
353 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
355 showPackageDot verbosity cli
356 ["find-module", moduleName] -> do
357 let match = maybe (==moduleName) id (substringCheck moduleName)
358 listPackages verbosity cli Nothing (Just match)
359 ["latest", pkgid_str] -> do
360 pkgid <- readGlobPkgId pkgid_str
361 latestPackage verbosity cli pkgid
362 ["describe", pkgid_str] -> do
363 pkgarg <- case substringCheck pkgid_str of
364 Nothing -> liftM Id (readGlobPkgId pkgid_str)
365 Just m -> return (Substring pkgid_str m)
366 describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
368 ["field", pkgid_str, fields] -> do
369 pkgarg <- case substringCheck pkgid_str of
370 Nothing -> liftM Id (readGlobPkgId pkgid_str)
371 Just m -> return (Substring pkgid_str m)
372 describeField verbosity cli pkgarg
373 (splitFields fields) (fromMaybe True mexpand_pkgroot)
376 checkConsistency verbosity cli
379 dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
382 recache verbosity cli
385 die ("missing command\n" ++
386 usageInfo (usageHeader prog) flags)
388 die ("command-line syntax error\n" ++
389 usageInfo (usageHeader prog) flags)
391 parseCheck :: ReadP a a -> String -> String -> IO a
392 parseCheck parser str what =
393 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
395 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
397 readGlobPkgId :: String -> IO PackageIdentifier
398 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
400 parseGlobPackageId :: ReadP r PackageIdentifier
406 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
408 -- globVersion means "all versions"
409 globVersion :: Version
410 globVersion = Version{ versionBranch=[], versionTags=["*"] }
412 -- -----------------------------------------------------------------------------
415 -- Some commands operate on a single database:
416 -- register, unregister, expose, hide
417 -- however these commands also check the union of the available databases
418 -- in order to check consistency. For example, register will check that
419 -- dependencies exist before registering a package.
421 -- Some commands operate on multiple databases, with overlapping semantics:
422 -- list, describe, field
426 location, locationAbsolute :: !FilePath,
427 -- We need both possibly-relative and definately-absolute package
428 -- db locations. This is because the relative location is used as
429 -- an identifier for the db, so it is important we do not modify it.
430 -- On the other hand we need the absolute path in a few places
431 -- particularly in relation to the ${pkgroot} stuff.
433 packages :: [InstalledPackageInfo]
436 type PackageDBStack = [PackageDB]
437 -- A stack of package databases. Convention: head is the topmost
440 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
441 allPackagesInStack = concatMap packages
443 getPkgDatabases :: Verbosity
444 -> Bool -- we are modifying, not reading
445 -> Bool -- read caches, if available
446 -> Bool -- expand vars, like ${pkgroot} and $topdir
448 -> IO (PackageDBStack,
449 -- the real package DB stack: [global,user] ++
450 -- DBs specified on the command line with -f.
452 -- which one to modify, if any
454 -- the package DBs specified on the command
455 -- line, or [global,user] otherwise. This
456 -- is used as the list of package DBs for
457 -- commands that just read the DB, such as 'list'.
459 getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
460 -- first we determine the location of the global package config. On Windows,
461 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
462 -- location is passed to the binary using the --global-config flag by the
464 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
466 case [ f | FlagGlobalConfig f <- my_flags ] of
467 [] -> do mb_dir <- getLibDir
469 Nothing -> die err_msg
471 r <- lookForPackageDBIn dir
473 Nothing -> die ("Can't find package database in " ++ dir)
474 Just path -> return path
475 fs -> return (last fs)
477 -- The value of the $topdir variable used in some package descriptions
478 -- Note that the way we calculate this is slightly different to how it
479 -- is done in ghc itself. We rely on the convention that the global
480 -- package db lives in ghc's libdir.
481 top_dir <- absolutePath (takeDirectory global_conf)
483 let no_user_db = FlagNoUserDb `elem` my_flags
485 -- get the location of the user package database, and create it if necessary
486 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
487 e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
490 if no_user_db then return Nothing else
492 Left _ -> return Nothing
494 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
495 dir = appdir </> subdir
496 r <- lookForPackageDBIn dir
498 Nothing -> return (Just (dir </> "package.conf.d", False))
499 Just f -> return (Just (f, True))
501 -- If the user database doesn't exist, and this command isn't a
502 -- "modify" command, then we won't attempt to create or use it.
504 | Just (user_conf,user_exists) <- mb_user_conf,
505 modify || user_exists = [user_conf, global_conf]
506 | otherwise = [global_conf]
508 e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
511 Left _ -> sys_databases
513 | last cs == "" -> init cs ++ sys_databases
515 where cs = parseSearchPath path
517 -- The "global" database is always the one at the bottom of the stack.
518 -- This is the database we modify by default.
519 virt_global_conf = last env_stack
521 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
522 where is_db_flag FlagUser
523 | Just (user_conf, _user_exists) <- mb_user_conf
525 is_db_flag FlagGlobal = Just virt_global_conf
526 is_db_flag (FlagConfig f) = Just f
527 is_db_flag _ = Nothing
529 let flag_db_names | null db_flags = env_stack
530 | otherwise = reverse (nub db_flags)
532 -- For a "modify" command, treat all the databases as
533 -- a stack, where we are modifying the top one, but it
534 -- can refer to packages in databases further down the
537 -- -f flags on the command line add to the database
538 -- stack, unless any of them are present in the stack
540 let final_stack = filter (`notElem` env_stack)
541 [ f | FlagConfig f <- reverse my_flags ]
544 -- the database we actually modify is the one mentioned
545 -- rightmost on the command-line.
547 | not modify = Nothing
548 | null db_flags = Just virt_global_conf
549 | otherwise = Just (last db_flags)
552 [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
553 if expand_vars then return (mungePackageDBPaths top_dir db)
555 | db_path <- final_stack ]
557 let flag_db_stack = [ db | db_name <- flag_db_names,
558 db <- db_stack, location db == db_name ]
560 return (db_stack, to_modify, flag_db_stack)
563 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
564 lookForPackageDBIn dir = do
565 let path_dir = dir </> "package.conf.d"
566 exists_dir <- doesDirectoryExist path_dir
567 if exists_dir then return (Just path_dir) else do
568 let path_file = dir </> "package.conf"
569 exists_file <- doesFileExist path_file
570 if exists_file then return (Just path_file) else return Nothing
572 readParseDatabase :: Verbosity
573 -> Maybe (FilePath,Bool)
578 readParseDatabase verbosity mb_user_conf use_cache path
579 -- the user database (only) is allowed to be non-existent
580 | Just (user_conf,False) <- mb_user_conf, path == user_conf
583 = do e <- tryIO $ getDirectoryContents path
586 pkgs <- parseMultiPackageConf verbosity path
589 | not use_cache -> ignore_cache
591 let cache = path </> cachefilename
592 tdir <- getModificationTime path
593 e_tcache <- tryIO $ getModificationTime cache
596 when (verbosity > Normal) $
597 warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
600 | tcache >= tdir -> do
601 when (verbosity > Normal) $
602 putStrLn ("using cache: " ++ cache)
603 pkgs <- myReadBinPackageDB cache
604 let pkgs' = map convertPackageInfoIn pkgs
607 when (verbosity >= Normal) $ do
608 warn ("WARNING: cache is out of date: " ++ cache)
609 warn " use 'ghc-pkg recache' to fix."
613 let confs = filter (".conf" `isSuffixOf`) fs
614 pkgs <- mapM (parseSingletonPackageConf verbosity) $
618 mkPackageDB pkgs = do
619 path_abs <- absolutePath path
622 locationAbsolute = path_abs,
626 -- read the package.cache file strictly, to work around a problem with
627 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
628 -- after it has been completely read, leading to a sharing violation
630 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
631 myReadBinPackageDB filepath = do
632 h <- openBinaryFile filepath ReadMode
634 b <- B.hGet h (fromIntegral sz)
636 return $ Bin.runGet Bin.get b
638 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
639 parseMultiPackageConf verbosity file = do
640 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
641 str <- readUTF8File file
642 let pkgs = map convertPackageInfoIn $ read str
643 Exception.evaluate pkgs
645 die ("error while parsing " ++ file ++ ": " ++ show e)
647 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
648 parseSingletonPackageConf verbosity file = do
649 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
650 readUTF8File file >>= fmap fst . parsePackageInfo
652 cachefilename :: FilePath
653 cachefilename = "package.cache"
655 mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
656 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
657 db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
659 pkgroot = takeDirectory (locationAbsolute db)
660 -- It so happens that for both styles of package db ("package.conf"
661 -- files and "package.conf.d" dirs) the pkgroot is the parent directory
662 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
664 -- TODO: This code is duplicated in compiler/main/Packages.lhs
665 mungePackagePaths :: FilePath -> FilePath
666 -> InstalledPackageInfo -> InstalledPackageInfo
667 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
668 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
669 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
670 -- The "pkgroot" is the directory containing the package database.
672 -- Also perform a similar substitution for the older GHC-specific
673 -- "$topdir" variable. The "topdir" is the location of the ghc
674 -- installation (obtained from the -B option).
675 mungePackagePaths top_dir pkgroot pkg =
677 importDirs = munge_paths (importDirs pkg),
678 includeDirs = munge_paths (includeDirs pkg),
679 libraryDirs = munge_paths (libraryDirs pkg),
680 frameworkDirs = munge_paths (frameworkDirs pkg),
681 haddockInterfaces = munge_paths (haddockInterfaces pkg),
682 -- haddock-html is allowed to be either a URL or a file
683 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
686 munge_paths = map munge_path
687 munge_urls = map munge_url
690 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
691 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
695 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
696 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
699 toUrlPath r p = "file:///"
700 -- URLs always use posix style '/' separators:
701 ++ FilePath.Posix.joinPath
702 (r : -- We need to drop a leading "/" or "\\"
704 dropWhile (all isPathSeparator)
705 (FilePath.splitDirectories p))
707 -- We could drop the separator here, and then use </> above. However,
708 -- by leaving it in and using ++ we keep the same path separator
709 -- rather than letting FilePath change it to use \ as the separator
710 stripVarPrefix var path = case stripPrefix var path of
712 Just cs@(c : _) | isPathSeparator c -> Just cs
716 -- -----------------------------------------------------------------------------
717 -- Creating a new package DB
719 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
720 initPackageDB filename verbosity _flags = do
721 let eexist = die ("cannot create: " ++ filename ++ " already exists")
722 b1 <- doesFileExist filename
724 b2 <- doesDirectoryExist filename
726 filename_abs <- absolutePath filename
727 changeDB verbosity [] PackageDB {
728 location = filename, locationAbsolute = filename_abs,
732 -- -----------------------------------------------------------------------------
735 registerPackage :: FilePath
738 -> Bool -- auto_ghci_libs
739 -> Bool -- expand_env_vars
743 registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
744 (db_stack, Just to_modify, _flag_dbs) <-
745 getPkgDatabases verbosity True True False{-expand vars-} my_flags
748 db_to_operate_on = my_head "register" $
749 filter ((== to_modify).location) db_stack
751 when (auto_ghci_libs && verbosity >= Silent) $
752 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
757 when (verbosity >= Normal) $
758 putStr "Reading package info from stdin ... "
759 -- fix the encoding to UTF-8, since this is an interchange format
760 hSetEncoding stdin utf8
763 when (verbosity >= Normal) $
764 putStr ("Reading package info from " ++ show f ++ " ... ")
767 expanded <- if expand_env_vars then expandEnvVars s force
770 (pkg, ws) <- parsePackageInfo expanded
771 when (verbosity >= Normal) $
774 -- report any warnings from the parse phase
775 _ <- reportValidateErrors [] ws
776 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
778 -- validate the expanded pkg, but register the unexpanded
779 pkgroot <- absolutePath (takeDirectory to_modify)
780 let top_dir = takeDirectory (location (last db_stack))
781 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
783 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
784 -- truncate the stack for validation, because we don't allow
785 -- packages lower in the stack to refer to those higher up.
786 validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
788 removes = [ RemovePackage p
789 | p <- packages db_to_operate_on,
790 sourcePackageId p == sourcePackageId pkg ]
792 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
796 -> IO (InstalledPackageInfo, [ValidateWarning])
797 parsePackageInfo str =
798 case parseInstalledPackageInfo str of
799 ParseOk warnings ok -> return (ok, ws)
801 ws = [ msg | PWarning msg <- warnings
802 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
803 ParseFailed err -> case locatedErrorMsg err of
804 (Nothing, s) -> die s
805 (Just l, s) -> die (show l ++ ": " ++ s)
807 -- -----------------------------------------------------------------------------
808 -- Making changes to a package database
810 data DBOp = RemovePackage InstalledPackageInfo
811 | AddPackage InstalledPackageInfo
812 | ModifyPackage InstalledPackageInfo
814 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
815 changeDB verbosity cmds db = do
816 let db' = updateInternalDB db cmds
817 isfile <- doesFileExist (location db)
819 then writeNewConfig verbosity (location db') (packages db')
821 createDirectoryIfMissing True (location db)
822 changeDBDir verbosity cmds db'
824 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
825 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
827 do_cmd pkgs (RemovePackage p) =
828 filter ((/= installedPackageId p) . installedPackageId) pkgs
829 do_cmd pkgs (AddPackage p) = p : pkgs
830 do_cmd pkgs (ModifyPackage p) =
831 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
834 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
835 changeDBDir verbosity cmds db = do
837 updateDBCache verbosity db
839 do_cmd (RemovePackage p) = do
840 let file = location db </> display (installedPackageId p) <.> "conf"
841 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
843 do_cmd (AddPackage p) = do
844 let file = location db </> display (installedPackageId p) <.> "conf"
845 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
846 writeFileUtf8Atomic file (showInstalledPackageInfo p)
847 do_cmd (ModifyPackage p) =
848 do_cmd (AddPackage p)
850 updateDBCache :: Verbosity -> PackageDB -> IO ()
851 updateDBCache verbosity db = do
852 let filename = location db </> cachefilename
853 when (verbosity > Normal) $
854 putStrLn ("writing cache " ++ filename)
855 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
857 if isPermissionError e
858 then die (filename ++ ": you don't have permission to modify this file")
861 -- -----------------------------------------------------------------------------
862 -- Exposing, Hiding, Unregistering are all similar
864 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
865 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
867 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
868 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
870 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
871 unregisterPackage = modifyPackage RemovePackage
874 :: (InstalledPackageInfo -> DBOp)
880 modifyPackage fn pkgid verbosity my_flags force = do
881 (db_stack, Just _to_modify, _flag_dbs) <-
882 getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
884 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
886 db_name = location db
889 pids = map sourcePackageId ps
891 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
892 new_db = updateInternalDB db cmds
894 old_broken = brokenPackages (allPackagesInStack db_stack)
895 rest_of_stack = filter ((/= db_name) . location) db_stack
896 new_stack = new_db : rest_of_stack
897 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
898 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
900 when (not (null newly_broken)) $
901 dieOrForceAll force ("unregistering " ++ display pkgid ++
902 " would break the following packages: "
903 ++ unwords (map display newly_broken))
905 changeDB verbosity cmds db
907 recache :: Verbosity -> [Flag] -> IO ()
908 recache verbosity my_flags = do
909 (db_stack, Just to_modify, _flag_dbs) <-
910 getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
912 db_to_operate_on = my_head "recache" $
913 filter ((== to_modify).location) db_stack
915 changeDB verbosity [] db_to_operate_on
917 -- -----------------------------------------------------------------------------
920 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
921 -> Maybe (String->Bool)
923 listPackages verbosity my_flags mPackageName mModuleName = do
924 let simple_output = FlagSimpleOutput `elem` my_flags
925 (db_stack, _, flag_db_stack) <-
926 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
928 let db_stack_filtered -- if a package is given, filter out all other packages
929 | Just this <- mPackageName =
930 [ db{ packages = filter (this `matchesPkg`) (packages db) }
931 | db <- flag_db_stack ]
932 | Just match <- mModuleName = -- packages which expose mModuleName
933 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
934 | db <- flag_db_stack ]
935 | otherwise = flag_db_stack
938 = [ db{ packages = sort_pkgs (packages db) }
939 | db <- db_stack_filtered ]
940 where sort_pkgs = sortBy cmpPkgIds
941 cmpPkgIds pkg1 pkg2 =
942 case pkgName p1 `compare` pkgName p2 of
945 EQ -> pkgVersion p1 `compare` pkgVersion p2
946 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
948 stack = reverse db_stack_sorted
950 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
952 pkg_map = allPackagesInStack db_stack
953 broken = map sourcePackageId (brokenPackages pkg_map)
955 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
956 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
958 pp_pkgs = map pp_pkg pkg_confs
960 | sourcePackageId p `elem` broken = printf "{%s}" doc
962 | otherwise = printf "(%s)" doc
963 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
966 InstalledPackageId ipid = installedPackageId p
967 pkg = display (sourcePackageId p)
969 show_simple = simplePackageList my_flags . allPackagesInStack
971 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
972 prog <- getProgramName
973 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
975 if simple_output then show_simple stack else do
977 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
978 mapM_ show_normal stack
981 show_colour withF db =
982 mconcat $ map (<#> termText "\n") $
983 (termText (location db) :
984 map (termText " " <#>) (map pp_pkg (packages db)))
987 | sourcePackageId p `elem` broken = withF Red doc
989 | otherwise = withF Blue doc
990 where doc | verbosity >= Verbose
991 = termText (printf "%s (%s)" pkg ipid)
995 InstalledPackageId ipid = installedPackageId p
996 pkg = display (sourcePackageId p)
998 is_tty <- hIsTerminalDevice stdout
1000 then mapM_ show_normal stack
1001 else do tty <- Terminfo.setupTermFromEnv
1002 case Terminfo.getCapability tty withForegroundColor of
1003 Nothing -> mapM_ show_normal stack
1004 Just w -> runTermOutput tty $ mconcat $
1005 map (show_colour w) stack
1008 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1009 simplePackageList my_flags pkgs = do
1010 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1012 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
1013 when (not (null pkgs)) $
1014 hPutStrLn stdout $ concat $ intersperse " " strs
1016 showPackageDot :: Verbosity -> [Flag] -> IO ()
1017 showPackageDot verbosity myflags = do
1018 (_, _, flag_db_stack) <-
1019 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
1021 let all_pkgs = allPackagesInStack flag_db_stack
1022 ipix = PackageIndex.fromList all_pkgs
1024 putStrLn "digraph {"
1025 let quote s = '"':s ++ "\""
1026 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1028 let from = display (sourcePackageId p),
1030 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1031 let to = display (sourcePackageId dep)
1035 -- -----------------------------------------------------------------------------
1036 -- Prints the highest (hidden or exposed) version of a package
1038 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1039 latestPackage verbosity my_flags pkgid = do
1040 (_, _, flag_db_stack) <-
1041 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1043 ps <- findPackages flag_db_stack (Id pkgid)
1044 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
1046 show_pkg [] = die "no matches"
1047 show_pkg pids = hPutStrLn stdout (display (last pids))
1049 -- -----------------------------------------------------------------------------
1052 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1053 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1054 (_, _, flag_db_stack) <-
1055 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1056 dbs <- findPackagesByDB flag_db_stack pkgarg
1057 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1058 | (db, pkgs) <- dbs, pkg <- pkgs ]
1060 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1061 dumpPackages verbosity my_flags expand_pkgroot = do
1062 (_, _, flag_db_stack) <-
1063 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1064 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1065 | db <- flag_db_stack, pkg <- packages db ]
1067 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1068 doDump expand_pkgroot pkgs = do
1069 -- fix the encoding to UTF-8, since this is an interchange format
1070 hSetEncoding stdout utf8
1074 then showInstalledPackageInfo pkg
1075 else showInstalledPackageInfo pkg ++ pkgrootField
1076 | (pkg, pkgloc) <- pkgs
1077 , let pkgroot = takeDirectory pkgloc
1078 pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
1080 -- PackageId is can have globVersion for the version
1081 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1082 findPackages db_stack pkgarg
1083 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1085 findPackagesByDB :: PackageDBStack -> PackageArg
1086 -> IO [(PackageDB, [InstalledPackageInfo])]
1087 findPackagesByDB db_stack pkgarg
1088 = case [ (db, matched)
1090 let matched = filter (pkgarg `matchesPkg`) (packages db),
1091 not (null matched) ] of
1092 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1095 pkg_msg (Id pkgid) = display pkgid
1096 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1098 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1100 = (pkgName pid == pkgName pid')
1101 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1103 realVersion :: PackageIdentifier -> Bool
1104 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1105 -- when versionBranch == [], this is a glob
1107 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1108 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1109 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1111 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
1112 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
1114 -- -----------------------------------------------------------------------------
1117 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1118 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1119 (_, _, flag_db_stack) <-
1120 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1121 fns <- toFields fields
1122 ps <- findPackages flag_db_stack pkgarg
1123 mapM_ (selectFields fns) ps
1124 where toFields [] = return []
1125 toFields (f:fs) = case toField f of
1126 Nothing -> die ("unknown field: " ++ f)
1127 Just fn -> do fns <- toFields fs
1129 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1131 toField :: String -> Maybe (InstalledPackageInfo -> String)
1132 -- backwards compatibility:
1133 toField "import_dirs" = Just $ strList . importDirs
1134 toField "source_dirs" = Just $ strList . importDirs
1135 toField "library_dirs" = Just $ strList . libraryDirs
1136 toField "hs_libraries" = Just $ strList . hsLibraries
1137 toField "extra_libraries" = Just $ strList . extraLibraries
1138 toField "include_dirs" = Just $ strList . includeDirs
1139 toField "c_includes" = Just $ strList . includes
1140 toField "package_deps" = Just $ strList . map display. depends
1141 toField "extra_cc_opts" = Just $ strList . ccOptions
1142 toField "extra_ld_opts" = Just $ strList . ldOptions
1143 toField "framework_dirs" = Just $ strList . frameworkDirs
1144 toField "extra_frameworks"= Just $ strList . frameworks
1145 toField s = showInstalledPackageInfoField s
1147 strList :: [String] -> String
1151 -- -----------------------------------------------------------------------------
1152 -- Check: Check consistency of installed packages
1154 checkConsistency :: Verbosity -> [Flag] -> IO ()
1155 checkConsistency verbosity my_flags = do
1157 getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
1158 -- check behaves like modify for the purposes of deciding which
1159 -- databases to use, because ordering is important.
1161 let simple_output = FlagSimpleOutput `elem` my_flags
1163 let pkgs = allPackagesInStack db_stack
1166 (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1168 then do when (not simple_output) $ do
1169 _ <- reportValidateErrors [] ws "" Nothing
1173 when (not simple_output) $ do
1174 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1175 _ <- reportValidateErrors es ws " " Nothing
1179 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1181 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1182 where not_in p = sourcePackageId p `notElem` all_ps
1183 all_ps = map sourcePackageId pkgs1
1185 let not_broken_pkgs = filterOut broken_pkgs pkgs
1186 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1187 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1189 when (not (null all_broken_pkgs)) $ do
1191 then simplePackageList my_flags all_broken_pkgs
1193 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1194 "listed above, or because they depend on a broken package.")
1195 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1197 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1200 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1201 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1202 closure pkgs db_stack = go pkgs db_stack
1204 go avail not_avail =
1205 case partition (depsAvailable avail) not_avail of
1206 ([], not_avail') -> (avail, not_avail')
1207 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1209 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1211 depsAvailable pkgs_ok pkg = null dangling
1212 where dangling = filter (`notElem` pids) (depends pkg)
1213 pids = map installedPackageId pkgs_ok
1215 -- we want mutually recursive groups of package to show up
1216 -- as broken. (#1750)
1218 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1219 brokenPackages pkgs = snd (closure [] pkgs)
1221 -- -----------------------------------------------------------------------------
1222 -- Manipulating package.conf files
1224 type InstalledPackageInfoString = InstalledPackageInfo_ String
1226 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1227 convertPackageInfoOut
1228 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1229 hiddenModules = h })) =
1230 pkgconf{ exposedModules = map display e,
1231 hiddenModules = map display h }
1233 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1234 convertPackageInfoIn
1235 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1236 hiddenModules = h })) =
1237 pkgconf{ exposedModules = map convert e,
1238 hiddenModules = map convert h }
1239 where convert = fromJust . simpleParse
1241 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1242 writeNewConfig verbosity filename ipis = do
1243 when (verbosity >= Normal) $
1244 hPutStr stdout "Writing new package config file... "
1245 createDirectoryIfMissing True $ takeDirectory filename
1246 let shown = concat $ intersperse ",\n "
1247 $ map (show . convertPackageInfoOut) ipis
1248 fileContents = "[" ++ shown ++ "\n]"
1249 writeFileUtf8Atomic filename fileContents
1251 if isPermissionError e
1252 then die (filename ++ ": you don't have permission to modify this file")
1254 when (verbosity >= Normal) $
1255 hPutStrLn stdout "done."
1257 -----------------------------------------------------------------------------
1258 -- Sanity-check a new package config, and automatically build GHCi libs
1261 type ValidateError = (Force,String)
1262 type ValidateWarning = String
1264 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1266 instance Monad Validate where
1267 return a = V $ return (a, [], [])
1269 (a, es, ws) <- runValidate m
1270 (b, es', ws') <- runValidate (k a)
1271 return (b,es++es',ws++ws')
1273 verror :: Force -> String -> Validate ()
1274 verror f s = V (return ((),[(f,s)],[]))
1276 vwarn :: String -> Validate ()
1277 vwarn s = V (return ((),[],["Warning: " ++ s]))
1279 liftIO :: IO a -> Validate a
1280 liftIO k = V (k >>= \a -> return (a,[],[]))
1282 -- returns False if we should die
1283 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1284 -> String -> Maybe Force -> IO Bool
1285 reportValidateErrors es ws prefix mb_force = do
1286 mapM_ (warn . (prefix++)) ws
1287 oks <- mapM report es
1291 | Just force <- mb_force
1293 then do reportError (prefix ++ s ++ " (ignoring)")
1295 else if f < CannotForce
1296 then do reportError (prefix ++ s ++ " (use --force to override)")
1298 else do reportError err
1300 | otherwise = do reportError err
1305 validatePackageConfig :: InstalledPackageInfo
1307 -> Bool -- auto-ghc-libs
1308 -> Bool -- update, or check
1311 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1312 (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1313 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1314 when (not ok) $ exitWith (ExitFailure 1)
1316 checkPackageConfig :: InstalledPackageInfo
1318 -> Bool -- auto-ghc-libs
1319 -> Bool -- update, or check
1321 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1322 checkInstalledPackageId pkg db_stack update
1324 checkDuplicates db_stack pkg update
1325 mapM_ (checkDep db_stack) (depends pkg)
1326 checkDuplicateDepends (depends pkg)
1327 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1328 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1329 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1330 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1331 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1332 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1334 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1335 -- ToDo: check these somehow?
1336 -- extra_libraries :: [String],
1337 -- c_includes :: [String],
1339 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1341 checkInstalledPackageId ipi db_stack update = do
1342 let ipid@(InstalledPackageId str) = installedPackageId ipi
1343 when (null str) $ verror CannotForce "missing id field"
1344 let dups = [ p | p <- allPackagesInStack db_stack,
1345 installedPackageId p == ipid ]
1346 when (not update && not (null dups)) $
1347 verror CannotForce $
1348 "package(s) with this id already exist: " ++
1349 unwords (map (display.packageId) dups)
1351 -- When the package name and version are put together, sometimes we can
1352 -- end up with a package id that cannot be parsed. This will lead to
1353 -- difficulties when the user wants to refer to the package later, so
1354 -- we check that the package id can be parsed properly here.
1355 checkPackageId :: InstalledPackageInfo -> Validate ()
1356 checkPackageId ipi =
1357 let str = display (sourcePackageId ipi) in
1358 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1360 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1361 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1363 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1364 checkDuplicates db_stack pkg update = do
1366 pkgid = sourcePackageId pkg
1367 pkgs = packages (head db_stack)
1369 -- Check whether this package id already exists in this DB
1371 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1372 verror CannotForce $
1373 "package " ++ display pkgid ++ " is already installed"
1376 uncasep = map toLower . display
1377 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1379 when (not update && not (null dups)) $ verror ForceAll $
1380 "Package names may be treated case-insensitively in the future.\n"++
1381 "Package " ++ display pkgid ++
1382 " overlaps with: " ++ unwords (map display dups)
1384 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1385 checkDir = checkPath False True
1386 checkFile = checkPath False False
1387 checkDirURL = checkPath True True
1389 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1390 checkPath url_ok is_dir warn_only thisfield d
1391 | url_ok && ("http://" `isPrefixOf` d
1392 || "https://" `isPrefixOf` d) = return ()
1395 , Just d' <- stripPrefix "file://" d
1396 = checkPath False is_dir warn_only thisfield d'
1398 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1399 -- variables having been expanded already, see mungePackagePaths.
1401 | isRelative d = verror ForceFiles $
1402 thisfield ++ ": " ++ d ++ " is a relative path which "
1403 ++ "makes no sense (as there is nothing for it to be "
1404 ++ "relative to). You can make paths relative to the "
1405 ++ "package database itself by using ${pkgroot}."
1406 -- relative paths don't make any sense; #4134
1408 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1410 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1411 ++ if is_dir then "directory" else "file"
1415 else verror ForceFiles msg
1417 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1418 checkDep db_stack pkgid
1419 | pkgid `elem` pkgids = return ()
1420 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1421 ++ "\" doesn't exist")
1423 all_pkgs = allPackagesInStack db_stack
1424 pkgids = map installedPackageId all_pkgs
1426 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1427 checkDuplicateDepends deps
1428 | null dups = return ()
1429 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1430 unwords (map display dups))
1432 dups = [ p | (p:_:_) <- group (sort deps) ]
1434 checkHSLib :: [String] -> Bool -> String -> Validate ()
1435 checkHSLib dirs auto_ghci_libs lib = do
1436 let batch_lib_file = "lib" ++ lib ++ ".a"
1437 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1439 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1441 Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
1443 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1444 doesFileExistOnPath file path = go path
1445 where go [] = return Nothing
1446 go (p:ps) = do b <- doesFileExistIn file p
1447 if b then return (Just p) else go ps
1449 doesFileExistIn :: String -> String -> IO Bool
1450 doesFileExistIn lib d = doesFileExist (d </> lib)
1452 checkModules :: InstalledPackageInfo -> Validate ()
1453 checkModules pkg = do
1454 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1456 findModule modl = do
1457 -- there's no .hi file for GHC.Prim
1458 if modl == fromString "GHC.Prim" then return () else do
1459 let file = toFilePath modl <.> "hi"
1460 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1461 when (isNothing m) $
1462 verror ForceFiles ("file " ++ file ++ " is missing")
1464 checkGHCiLib :: String -> String -> String -> Bool -> IO ()
1465 checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
1466 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1467 | otherwise = return ()
1469 ghci_lib_file = lib <.> "o"
1471 -- automatically build the GHCi version of a batch lib,
1472 -- using ld --whole-archive.
1474 autoBuildGHCiLib :: String -> String -> String -> IO ()
1475 autoBuildGHCiLib dir batch_file ghci_file = do
1476 let ghci_lib_file = dir ++ '/':ghci_file
1477 batch_lib_file = dir ++ '/':batch_file
1478 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1479 #if defined(darwin_HOST_OS)
1480 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1481 #elif defined(mingw32_HOST_OS)
1482 execDir <- getLibDir
1483 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1485 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1487 when (r /= ExitSuccess) $ exitWith r
1488 hPutStrLn stderr (" done.")
1490 -- -----------------------------------------------------------------------------
1491 -- Searching for modules
1495 findModules :: [FilePath] -> IO [String]
1497 mms <- mapM searchDir paths
1500 searchDir path prefix = do
1501 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1502 searchEntries path prefix fs
1504 searchEntries path prefix [] = return []
1505 searchEntries path prefix (f:fs)
1506 | looks_like_a_module = do
1507 ms <- searchEntries path prefix fs
1508 return (prefix `joinModule` f : ms)
1509 | looks_like_a_component = do
1510 ms <- searchDir (path </> f) (prefix `joinModule` f)
1511 ms' <- searchEntries path prefix fs
1514 searchEntries path prefix fs
1517 (base,suffix) = splitFileExt f
1518 looks_like_a_module =
1519 suffix `elem` haskell_suffixes &&
1520 all okInModuleName base
1521 looks_like_a_component =
1522 null suffix && all okInModuleName base
1528 -- ---------------------------------------------------------------------------
1529 -- expanding environment variables in the package configuration
1531 expandEnvVars :: String -> Force -> IO String
1532 expandEnvVars str0 force = go str0 ""
1534 go "" acc = return $! reverse acc
1535 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1536 = do value <- lookupEnvVar var
1537 go rest (reverse value ++ acc)
1538 where close c = c == '}' || c == '\n' -- don't span newlines
1542 lookupEnvVar :: String -> IO String
1543 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1544 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1546 catchIO (System.Environment.getEnv nm)
1547 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1551 -----------------------------------------------------------------------------
1553 getProgramName :: IO String
1554 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1555 where str `withoutSuffix` suff
1556 | suff `isSuffixOf` str = take (length str - length suff) str
1559 bye :: String -> IO a
1560 bye s = putStr s >> exitWith ExitSuccess
1562 die :: String -> IO a
1565 dieWith :: Int -> String -> IO a
1568 prog <- getProgramName
1569 hPutStrLn stderr (prog ++ ": " ++ s)
1570 exitWith (ExitFailure ec)
1572 dieOrForceAll :: Force -> String -> IO ()
1573 dieOrForceAll ForceAll s = ignoreError s
1574 dieOrForceAll _other s = dieForcible s
1576 warn :: String -> IO ()
1579 ignoreError :: String -> IO ()
1580 ignoreError s = reportError (s ++ " (ignoring)")
1582 reportError :: String -> IO ()
1583 reportError s = do hFlush stdout; hPutStrLn stderr s
1585 dieForcible :: String -> IO ()
1586 dieForcible s = die (s ++ " (use --force to override)")
1588 my_head :: String -> [a] -> a
1589 my_head s [] = error s
1590 my_head _ (x : _) = x
1592 -----------------------------------------
1593 -- Cut and pasted from ghc/compiler/main/SysTools
1595 #if defined(mingw32_HOST_OS)
1596 subst :: Char -> Char -> String -> String
1597 subst a b ls = map (\ x -> if x == a then b else x) ls
1599 unDosifyPath :: FilePath -> FilePath
1600 unDosifyPath xs = subst '\\' '/' xs
1602 getLibDir :: IO (Maybe String)
1603 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1605 -- (getExecDir cmd) returns the directory in which the current
1606 -- executable, which should be called 'cmd', is running
1607 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1608 -- you'll get "/a/b/c" back as the result
1609 getExecDir :: String -> IO (Maybe String)
1611 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1612 where initN n = reverse . drop n . reverse
1613 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1615 getExecPath :: IO (Maybe String)
1616 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1618 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1619 ret <- c_GetModuleFileName nullPtr buf size
1622 _ | ret < size -> fmap Just $ peekCWString buf
1623 | otherwise -> try_size (size * 2)
1625 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
1626 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1628 getLibDir :: IO (Maybe String)
1629 getLibDir = return Nothing
1632 -----------------------------------------
1633 -- Adapted from ghc/compiler/utils/Panic
1635 installSignalHandlers :: IO ()
1636 installSignalHandlers = do
1637 threadid <- myThreadId
1639 interrupt = Exception.throwTo threadid
1640 (Exception.ErrorCall "interrupted")
1642 #if !defined(mingw32_HOST_OS)
1643 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1644 _ <- installHandler sigINT (Catch interrupt) Nothing
1647 -- GHC 6.3+ has support for console events on Windows
1648 -- NOTE: running GHCi under a bash shell for some reason requires
1649 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1650 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1651 -- why --SDM 17/12/2004
1652 let sig_handler ControlC = interrupt
1653 sig_handler Break = interrupt
1654 sig_handler _ = return ()
1656 _ <- installHandler (Catch sig_handler)
1660 #if mingw32_HOST_OS || mingw32_TARGET_OS
1661 throwIOIO :: Exception.IOException -> IO a
1662 throwIOIO = Exception.throwIO
1665 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1666 catchIO = Exception.catch
1668 catchError :: IO a -> (String -> IO a) -> IO a
1669 catchError io handler = io `Exception.catch` handler'
1670 where handler' (Exception.ErrorCall err) = handler err
1672 tryIO :: IO a -> IO (Either Exception.IOException a)
1673 tryIO = Exception.try
1675 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1676 writeBinaryFileAtomic targetFile obj =
1677 withFileAtomic targetFile $ \h -> do
1678 hSetBinaryMode h True
1679 B.hPutStr h (Bin.encode obj)
1681 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1682 writeFileUtf8Atomic targetFile content =
1683 withFileAtomic targetFile $ \h -> do
1687 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1688 -- to use text files here, rather than binary files.
1689 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1690 withFileAtomic targetFile write_content = do
1691 (newFile, newHandle) <- openNewFile targetDir template
1692 do write_content newHandle
1694 #if mingw32_HOST_OS || mingw32_TARGET_OS
1695 renameFile newFile targetFile
1696 -- If the targetFile exists then renameFile will fail
1697 `catchIO` \err -> do
1698 exists <- doesFileExist targetFile
1700 then do removeFileSafe targetFile
1701 -- Big fat hairy race condition
1702 renameFile newFile targetFile
1703 -- If the removeFile succeeds and the renameFile fails
1704 -- then we've lost the atomic property.
1707 renameFile newFile targetFile
1709 `Exception.onException` do hClose newHandle
1710 removeFileSafe newFile
1712 template = targetName <.> "tmp"
1713 targetDir | null targetDir_ = "."
1714 | otherwise = targetDir_
1715 --TODO: remove this when takeDirectory/splitFileName is fixed
1716 -- to always return a valid dir
1717 (targetDir_,targetName) = splitFileName targetFile
1719 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1720 openNewFile dir template = do
1721 -- this was added to System.IO in 6.12.1
1722 -- we must use this version because the version below opens the file
1724 openTempFileWithDefaultPermissions dir template
1726 -- | The function splits the given string to substrings
1727 -- using 'isSearchPathSeparator'.
1728 parseSearchPath :: String -> [FilePath]
1729 parseSearchPath path = split path
1731 split :: String -> [String]
1735 _:rest -> chunk : split rest
1739 #ifdef mingw32_HOST_OS
1740 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1744 (chunk', rest') = break isSearchPathSeparator s
1746 readUTF8File :: FilePath -> IO String
1747 readUTF8File file = do
1748 h <- openFile file ReadMode
1749 -- fix the encoding to UTF-8
1753 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1754 removeFileSafe :: FilePath -> IO ()
1756 removeFile fn `catchIO` \ e ->
1757 when (not $ isDoesNotExistError e) $ ioError e
1759 absolutePath :: FilePath -> IO FilePath
1760 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory