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 mungePackagePaths :: FilePath -> FilePath
665 -> InstalledPackageInfo -> InstalledPackageInfo
666 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
667 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
668 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
669 -- The "pkgroot" is the directory containing the package database.
671 -- Also perform a similar substitution for the older GHC-specific
672 -- "$topdir" variable. The "topdir" is the location of the ghc
673 -- installation (obtained from the -B option).
674 mungePackagePaths top_dir pkgroot pkg =
676 importDirs = munge_paths (importDirs pkg),
677 includeDirs = munge_paths (includeDirs pkg),
678 libraryDirs = munge_paths (libraryDirs pkg),
679 frameworkDirs = munge_paths (frameworkDirs pkg),
680 haddockInterfaces = munge_paths (haddockInterfaces pkg),
681 haddockHTMLs = munge_urls (haddockHTMLs pkg)
684 munge_paths = map munge_path
685 munge_urls = map munge_url
688 | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
689 | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
695 | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
696 | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
701 toUrlPath r p = "file:///"
702 -- URLs always use posix style '/' separators:
703 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
705 stripVarPrefix var (root:path')
706 | Just [sep] <- stripPrefix var root
707 , isPathSeparator sep
708 = Just (joinPath path')
710 stripVarPrefix _ _ = Nothing
713 -- -----------------------------------------------------------------------------
714 -- Creating a new package DB
716 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
717 initPackageDB filename verbosity _flags = do
718 let eexist = die ("cannot create: " ++ filename ++ " already exists")
719 b1 <- doesFileExist filename
721 b2 <- doesDirectoryExist filename
723 filename_abs <- absolutePath filename
724 changeDB verbosity [] PackageDB {
725 location = filename, locationAbsolute = filename_abs,
729 -- -----------------------------------------------------------------------------
732 registerPackage :: FilePath
735 -> Bool -- auto_ghci_libs
736 -> Bool -- expand_env_vars
740 registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
741 (db_stack, Just to_modify, _flag_dbs) <-
742 getPkgDatabases verbosity True True False{-expand vars-} my_flags
745 db_to_operate_on = my_head "register" $
746 filter ((== to_modify).location) db_stack
748 when (auto_ghci_libs && verbosity >= Silent) $
749 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
754 when (verbosity >= Normal) $
755 putStr "Reading package info from stdin ... "
756 -- fix the encoding to UTF-8, since this is an interchange format
757 hSetEncoding stdin utf8
760 when (verbosity >= Normal) $
761 putStr ("Reading package info from " ++ show f ++ " ... ")
764 expanded <- if expand_env_vars then expandEnvVars s force
767 (pkg, ws) <- parsePackageInfo expanded
768 when (verbosity >= Normal) $
771 -- report any warnings from the parse phase
772 _ <- reportValidateErrors [] ws
773 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
775 -- validate the expanded pkg, but register the unexpanded
776 pkgroot <- absolutePath (takeDirectory to_modify)
777 let top_dir = takeDirectory (location (last db_stack))
778 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
780 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
781 -- truncate the stack for validation, because we don't allow
782 -- packages lower in the stack to refer to those higher up.
783 validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
785 removes = [ RemovePackage p
786 | p <- packages db_to_operate_on,
787 sourcePackageId p == sourcePackageId pkg ]
789 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
793 -> IO (InstalledPackageInfo, [ValidateWarning])
794 parsePackageInfo str =
795 case parseInstalledPackageInfo str of
796 ParseOk warnings ok -> return (ok, ws)
798 ws = [ msg | PWarning msg <- warnings
799 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
800 ParseFailed err -> case locatedErrorMsg err of
801 (Nothing, s) -> die s
802 (Just l, s) -> die (show l ++ ": " ++ s)
804 -- -----------------------------------------------------------------------------
805 -- Making changes to a package database
807 data DBOp = RemovePackage InstalledPackageInfo
808 | AddPackage InstalledPackageInfo
809 | ModifyPackage InstalledPackageInfo
811 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
812 changeDB verbosity cmds db = do
813 let db' = updateInternalDB db cmds
814 isfile <- doesFileExist (location db)
816 then writeNewConfig verbosity (location db') (packages db')
818 createDirectoryIfMissing True (location db)
819 changeDBDir verbosity cmds db'
821 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
822 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
824 do_cmd pkgs (RemovePackage p) =
825 filter ((/= installedPackageId p) . installedPackageId) pkgs
826 do_cmd pkgs (AddPackage p) = p : pkgs
827 do_cmd pkgs (ModifyPackage p) =
828 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
831 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
832 changeDBDir verbosity cmds db = do
834 updateDBCache verbosity db
836 do_cmd (RemovePackage p) = do
837 let file = location db </> display (installedPackageId p) <.> "conf"
838 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
840 do_cmd (AddPackage p) = do
841 let file = location db </> display (installedPackageId p) <.> "conf"
842 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
843 writeFileUtf8Atomic file (showInstalledPackageInfo p)
844 do_cmd (ModifyPackage p) =
845 do_cmd (AddPackage p)
847 updateDBCache :: Verbosity -> PackageDB -> IO ()
848 updateDBCache verbosity db = do
849 let filename = location db </> cachefilename
850 when (verbosity > Normal) $
851 putStrLn ("writing cache " ++ filename)
852 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
854 if isPermissionError e
855 then die (filename ++ ": you don't have permission to modify this file")
858 -- -----------------------------------------------------------------------------
859 -- Exposing, Hiding, Unregistering are all similar
861 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
862 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
864 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
865 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
867 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
868 unregisterPackage = modifyPackage RemovePackage
871 :: (InstalledPackageInfo -> DBOp)
877 modifyPackage fn pkgid verbosity my_flags force = do
878 (db_stack, Just _to_modify, _flag_dbs) <-
879 getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
881 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
883 db_name = location db
886 pids = map sourcePackageId ps
888 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
889 new_db = updateInternalDB db cmds
891 old_broken = brokenPackages (allPackagesInStack db_stack)
892 rest_of_stack = filter ((/= db_name) . location) db_stack
893 new_stack = new_db : rest_of_stack
894 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
895 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
897 when (not (null newly_broken)) $
898 dieOrForceAll force ("unregistering " ++ display pkgid ++
899 " would break the following packages: "
900 ++ unwords (map display newly_broken))
902 changeDB verbosity cmds db
904 recache :: Verbosity -> [Flag] -> IO ()
905 recache verbosity my_flags = do
906 (db_stack, Just to_modify, _flag_dbs) <-
907 getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
909 db_to_operate_on = my_head "recache" $
910 filter ((== to_modify).location) db_stack
912 changeDB verbosity [] db_to_operate_on
914 -- -----------------------------------------------------------------------------
917 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
918 -> Maybe (String->Bool)
920 listPackages verbosity my_flags mPackageName mModuleName = do
921 let simple_output = FlagSimpleOutput `elem` my_flags
922 (db_stack, _, flag_db_stack) <-
923 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
925 let db_stack_filtered -- if a package is given, filter out all other packages
926 | Just this <- mPackageName =
927 [ db{ packages = filter (this `matchesPkg`) (packages db) }
928 | db <- flag_db_stack ]
929 | Just match <- mModuleName = -- packages which expose mModuleName
930 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
931 | db <- flag_db_stack ]
932 | otherwise = flag_db_stack
935 = [ db{ packages = sort_pkgs (packages db) }
936 | db <- db_stack_filtered ]
937 where sort_pkgs = sortBy cmpPkgIds
938 cmpPkgIds pkg1 pkg2 =
939 case pkgName p1 `compare` pkgName p2 of
942 EQ -> pkgVersion p1 `compare` pkgVersion p2
943 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
945 stack = reverse db_stack_sorted
947 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
949 pkg_map = allPackagesInStack db_stack
950 broken = map sourcePackageId (brokenPackages pkg_map)
952 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
953 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
955 pp_pkgs = map pp_pkg pkg_confs
957 | sourcePackageId p `elem` broken = printf "{%s}" doc
959 | otherwise = printf "(%s)" doc
960 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
963 InstalledPackageId ipid = installedPackageId p
964 pkg = display (sourcePackageId p)
966 show_simple = simplePackageList my_flags . allPackagesInStack
968 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
969 prog <- getProgramName
970 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
972 if simple_output then show_simple stack else do
974 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
975 mapM_ show_normal stack
978 show_colour withF db =
979 mconcat $ map (<#> termText "\n") $
980 (termText (location db) :
981 map (termText " " <#>) (map pp_pkg (packages db)))
984 | sourcePackageId p `elem` broken = withF Red doc
986 | otherwise = withF Blue doc
987 where doc | verbosity >= Verbose
988 = termText (printf "%s (%s)" pkg ipid)
992 InstalledPackageId ipid = installedPackageId p
993 pkg = display (sourcePackageId p)
995 is_tty <- hIsTerminalDevice stdout
997 then mapM_ show_normal stack
998 else do tty <- Terminfo.setupTermFromEnv
999 case Terminfo.getCapability tty withForegroundColor of
1000 Nothing -> mapM_ show_normal stack
1001 Just w -> runTermOutput tty $ mconcat $
1002 map (show_colour w) stack
1005 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1006 simplePackageList my_flags pkgs = do
1007 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1009 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
1010 when (not (null pkgs)) $
1011 hPutStrLn stdout $ concat $ intersperse " " strs
1013 showPackageDot :: Verbosity -> [Flag] -> IO ()
1014 showPackageDot verbosity myflags = do
1015 (_, _, flag_db_stack) <-
1016 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
1018 let all_pkgs = allPackagesInStack flag_db_stack
1019 ipix = PackageIndex.fromList all_pkgs
1021 putStrLn "digraph {"
1022 let quote s = '"':s ++ "\""
1023 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1025 let from = display (sourcePackageId p),
1027 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1028 let to = display (sourcePackageId dep)
1032 -- -----------------------------------------------------------------------------
1033 -- Prints the highest (hidden or exposed) version of a package
1035 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1036 latestPackage verbosity my_flags pkgid = do
1037 (_, _, flag_db_stack) <-
1038 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1040 ps <- findPackages flag_db_stack (Id pkgid)
1041 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
1043 show_pkg [] = die "no matches"
1044 show_pkg pids = hPutStrLn stdout (display (last pids))
1046 -- -----------------------------------------------------------------------------
1049 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1050 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1051 (_, _, flag_db_stack) <-
1052 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1053 dbs <- findPackagesByDB flag_db_stack pkgarg
1054 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1055 | (db, pkgs) <- dbs, pkg <- pkgs ]
1057 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1058 dumpPackages verbosity my_flags expand_pkgroot = do
1059 (_, _, flag_db_stack) <-
1060 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1061 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1062 | db <- flag_db_stack, pkg <- packages db ]
1064 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1065 doDump expand_pkgroot pkgs = do
1066 -- fix the encoding to UTF-8, since this is an interchange format
1067 hSetEncoding stdout utf8
1071 then showInstalledPackageInfo pkg
1072 else showInstalledPackageInfo pkg ++ pkgrootField
1073 | (pkg, pkgloc) <- pkgs
1074 , let pkgroot = takeDirectory pkgloc
1075 pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
1077 -- PackageId is can have globVersion for the version
1078 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1079 findPackages db_stack pkgarg
1080 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1082 findPackagesByDB :: PackageDBStack -> PackageArg
1083 -> IO [(PackageDB, [InstalledPackageInfo])]
1084 findPackagesByDB db_stack pkgarg
1085 = case [ (db, matched)
1087 let matched = filter (pkgarg `matchesPkg`) (packages db),
1088 not (null matched) ] of
1089 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1092 pkg_msg (Id pkgid) = display pkgid
1093 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1095 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1097 = (pkgName pid == pkgName pid')
1098 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1100 realVersion :: PackageIdentifier -> Bool
1101 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1102 -- when versionBranch == [], this is a glob
1104 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1105 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1106 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1108 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
1109 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
1111 -- -----------------------------------------------------------------------------
1114 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1115 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1116 (_, _, flag_db_stack) <-
1117 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1118 fns <- toFields fields
1119 ps <- findPackages flag_db_stack pkgarg
1120 mapM_ (selectFields fns) ps
1121 where toFields [] = return []
1122 toFields (f:fs) = case toField f of
1123 Nothing -> die ("unknown field: " ++ f)
1124 Just fn -> do fns <- toFields fs
1126 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1128 toField :: String -> Maybe (InstalledPackageInfo -> String)
1129 -- backwards compatibility:
1130 toField "import_dirs" = Just $ strList . importDirs
1131 toField "source_dirs" = Just $ strList . importDirs
1132 toField "library_dirs" = Just $ strList . libraryDirs
1133 toField "hs_libraries" = Just $ strList . hsLibraries
1134 toField "extra_libraries" = Just $ strList . extraLibraries
1135 toField "include_dirs" = Just $ strList . includeDirs
1136 toField "c_includes" = Just $ strList . includes
1137 toField "package_deps" = Just $ strList . map display. depends
1138 toField "extra_cc_opts" = Just $ strList . ccOptions
1139 toField "extra_ld_opts" = Just $ strList . ldOptions
1140 toField "framework_dirs" = Just $ strList . frameworkDirs
1141 toField "extra_frameworks"= Just $ strList . frameworks
1142 toField s = showInstalledPackageInfoField s
1144 strList :: [String] -> String
1148 -- -----------------------------------------------------------------------------
1149 -- Check: Check consistency of installed packages
1151 checkConsistency :: Verbosity -> [Flag] -> IO ()
1152 checkConsistency verbosity my_flags = do
1154 getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
1155 -- check behaves like modify for the purposes of deciding which
1156 -- databases to use, because ordering is important.
1158 let simple_output = FlagSimpleOutput `elem` my_flags
1160 let pkgs = allPackagesInStack db_stack
1163 (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1165 then do when (not simple_output) $ do
1166 _ <- reportValidateErrors [] ws "" Nothing
1170 when (not simple_output) $ do
1171 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1172 _ <- reportValidateErrors es ws " " Nothing
1176 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1178 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1179 where not_in p = sourcePackageId p `notElem` all_ps
1180 all_ps = map sourcePackageId pkgs1
1182 let not_broken_pkgs = filterOut broken_pkgs pkgs
1183 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1184 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1186 when (not (null all_broken_pkgs)) $ do
1188 then simplePackageList my_flags all_broken_pkgs
1190 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1191 "listed above, or because they depend on a broken package.")
1192 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1194 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1197 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1198 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1199 closure pkgs db_stack = go pkgs db_stack
1201 go avail not_avail =
1202 case partition (depsAvailable avail) not_avail of
1203 ([], not_avail') -> (avail, not_avail')
1204 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1206 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1208 depsAvailable pkgs_ok pkg = null dangling
1209 where dangling = filter (`notElem` pids) (depends pkg)
1210 pids = map installedPackageId pkgs_ok
1212 -- we want mutually recursive groups of package to show up
1213 -- as broken. (#1750)
1215 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1216 brokenPackages pkgs = snd (closure [] pkgs)
1218 -- -----------------------------------------------------------------------------
1219 -- Manipulating package.conf files
1221 type InstalledPackageInfoString = InstalledPackageInfo_ String
1223 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1224 convertPackageInfoOut
1225 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1226 hiddenModules = h })) =
1227 pkgconf{ exposedModules = map display e,
1228 hiddenModules = map display h }
1230 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1231 convertPackageInfoIn
1232 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1233 hiddenModules = h })) =
1234 pkgconf{ exposedModules = map convert e,
1235 hiddenModules = map convert h }
1236 where convert = fromJust . simpleParse
1238 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1239 writeNewConfig verbosity filename ipis = do
1240 when (verbosity >= Normal) $
1241 hPutStr stdout "Writing new package config file... "
1242 createDirectoryIfMissing True $ takeDirectory filename
1243 let shown = concat $ intersperse ",\n "
1244 $ map (show . convertPackageInfoOut) ipis
1245 fileContents = "[" ++ shown ++ "\n]"
1246 writeFileUtf8Atomic filename fileContents
1248 if isPermissionError e
1249 then die (filename ++ ": you don't have permission to modify this file")
1251 when (verbosity >= Normal) $
1252 hPutStrLn stdout "done."
1254 -----------------------------------------------------------------------------
1255 -- Sanity-check a new package config, and automatically build GHCi libs
1258 type ValidateError = (Force,String)
1259 type ValidateWarning = String
1261 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1263 instance Monad Validate where
1264 return a = V $ return (a, [], [])
1266 (a, es, ws) <- runValidate m
1267 (b, es', ws') <- runValidate (k a)
1268 return (b,es++es',ws++ws')
1270 verror :: Force -> String -> Validate ()
1271 verror f s = V (return ((),[(f,s)],[]))
1273 vwarn :: String -> Validate ()
1274 vwarn s = V (return ((),[],["Warning: " ++ s]))
1276 liftIO :: IO a -> Validate a
1277 liftIO k = V (k >>= \a -> return (a,[],[]))
1279 -- returns False if we should die
1280 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1281 -> String -> Maybe Force -> IO Bool
1282 reportValidateErrors es ws prefix mb_force = do
1283 mapM_ (warn . (prefix++)) ws
1284 oks <- mapM report es
1288 | Just force <- mb_force
1290 then do reportError (prefix ++ s ++ " (ignoring)")
1292 else if f < CannotForce
1293 then do reportError (prefix ++ s ++ " (use --force to override)")
1295 else do reportError err
1297 | otherwise = do reportError err
1302 validatePackageConfig :: InstalledPackageInfo
1304 -> Bool -- auto-ghc-libs
1305 -> Bool -- update, or check
1308 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1309 (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1310 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1311 when (not ok) $ exitWith (ExitFailure 1)
1313 checkPackageConfig :: InstalledPackageInfo
1315 -> Bool -- auto-ghc-libs
1316 -> Bool -- update, or check
1318 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1319 checkInstalledPackageId pkg db_stack update
1321 checkDuplicates db_stack pkg update
1322 mapM_ (checkDep db_stack) (depends pkg)
1323 checkDuplicateDepends (depends pkg)
1324 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1325 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1326 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1327 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1328 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1329 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1331 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1332 -- ToDo: check these somehow?
1333 -- extra_libraries :: [String],
1334 -- c_includes :: [String],
1336 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1338 checkInstalledPackageId ipi db_stack update = do
1339 let ipid@(InstalledPackageId str) = installedPackageId ipi
1340 when (null str) $ verror CannotForce "missing id field"
1341 let dups = [ p | p <- allPackagesInStack db_stack,
1342 installedPackageId p == ipid ]
1343 when (not update && not (null dups)) $
1344 verror CannotForce $
1345 "package(s) with this id already exist: " ++
1346 unwords (map (display.packageId) dups)
1348 -- When the package name and version are put together, sometimes we can
1349 -- end up with a package id that cannot be parsed. This will lead to
1350 -- difficulties when the user wants to refer to the package later, so
1351 -- we check that the package id can be parsed properly here.
1352 checkPackageId :: InstalledPackageInfo -> Validate ()
1353 checkPackageId ipi =
1354 let str = display (sourcePackageId ipi) in
1355 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1357 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1358 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1360 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1361 checkDuplicates db_stack pkg update = do
1363 pkgid = sourcePackageId pkg
1364 pkgs = packages (head db_stack)
1366 -- Check whether this package id already exists in this DB
1368 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1369 verror CannotForce $
1370 "package " ++ display pkgid ++ " is already installed"
1373 uncasep = map toLower . display
1374 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1376 when (not update && not (null dups)) $ verror ForceAll $
1377 "Package names may be treated case-insensitively in the future.\n"++
1378 "Package " ++ display pkgid ++
1379 " overlaps with: " ++ unwords (map display dups)
1381 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1382 checkDir = checkPath False True
1383 checkFile = checkPath False False
1384 checkDirURL = checkPath True True
1386 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1387 checkPath url_ok is_dir warn_only thisfield d
1388 | url_ok && ("http://" `isPrefixOf` d
1389 || "https://" `isPrefixOf` d) = return ()
1392 , Just d' <- stripPrefix "file://" d
1393 = checkPath False is_dir warn_only thisfield d'
1395 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1396 -- variables having been expanded already, see mungePackagePaths.
1398 | isRelative d = verror ForceFiles $
1399 thisfield ++ ": " ++ d ++ " is a relative path which "
1400 ++ "makes no sense (as there is nothing for it to be "
1401 ++ "relative to). You can make paths relative to the "
1402 ++ "package database itself by using ${pkgroot}."
1403 -- relative paths don't make any sense; #4134
1405 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1407 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1408 ++ if is_dir then "directory" else "file"
1412 else verror ForceFiles msg
1414 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1415 checkDep db_stack pkgid
1416 | pkgid `elem` pkgids = return ()
1417 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1418 ++ "\" doesn't exist")
1420 all_pkgs = allPackagesInStack db_stack
1421 pkgids = map installedPackageId all_pkgs
1423 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1424 checkDuplicateDepends deps
1425 | null dups = return ()
1426 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1427 unwords (map display dups))
1429 dups = [ p | (p:_:_) <- group (sort deps) ]
1431 checkHSLib :: [String] -> Bool -> String -> Validate ()
1432 checkHSLib dirs auto_ghci_libs lib = do
1433 let batch_lib_file = "lib" ++ lib ++ ".a"
1434 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1436 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1438 Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
1440 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1441 doesFileExistOnPath file path = go path
1442 where go [] = return Nothing
1443 go (p:ps) = do b <- doesFileExistIn file p
1444 if b then return (Just p) else go ps
1446 doesFileExistIn :: String -> String -> IO Bool
1447 doesFileExistIn lib d = doesFileExist (d </> lib)
1449 checkModules :: InstalledPackageInfo -> Validate ()
1450 checkModules pkg = do
1451 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1453 findModule modl = do
1454 -- there's no .hi file for GHC.Prim
1455 if modl == fromString "GHC.Prim" then return () else do
1456 let file = toFilePath modl <.> "hi"
1457 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1458 when (isNothing m) $
1459 verror ForceFiles ("file " ++ file ++ " is missing")
1461 checkGHCiLib :: String -> String -> String -> Bool -> IO ()
1462 checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
1463 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1464 | otherwise = return ()
1466 ghci_lib_file = lib <.> "o"
1468 -- automatically build the GHCi version of a batch lib,
1469 -- using ld --whole-archive.
1471 autoBuildGHCiLib :: String -> String -> String -> IO ()
1472 autoBuildGHCiLib dir batch_file ghci_file = do
1473 let ghci_lib_file = dir ++ '/':ghci_file
1474 batch_lib_file = dir ++ '/':batch_file
1475 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1476 #if defined(darwin_HOST_OS)
1477 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1478 #elif defined(mingw32_HOST_OS)
1479 execDir <- getLibDir
1480 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1482 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1484 when (r /= ExitSuccess) $ exitWith r
1485 hPutStrLn stderr (" done.")
1487 -- -----------------------------------------------------------------------------
1488 -- Searching for modules
1492 findModules :: [FilePath] -> IO [String]
1494 mms <- mapM searchDir paths
1497 searchDir path prefix = do
1498 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1499 searchEntries path prefix fs
1501 searchEntries path prefix [] = return []
1502 searchEntries path prefix (f:fs)
1503 | looks_like_a_module = do
1504 ms <- searchEntries path prefix fs
1505 return (prefix `joinModule` f : ms)
1506 | looks_like_a_component = do
1507 ms <- searchDir (path </> f) (prefix `joinModule` f)
1508 ms' <- searchEntries path prefix fs
1511 searchEntries path prefix fs
1514 (base,suffix) = splitFileExt f
1515 looks_like_a_module =
1516 suffix `elem` haskell_suffixes &&
1517 all okInModuleName base
1518 looks_like_a_component =
1519 null suffix && all okInModuleName base
1525 -- ---------------------------------------------------------------------------
1526 -- expanding environment variables in the package configuration
1528 expandEnvVars :: String -> Force -> IO String
1529 expandEnvVars str0 force = go str0 ""
1531 go "" acc = return $! reverse acc
1532 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1533 = do value <- lookupEnvVar var
1534 go rest (reverse value ++ acc)
1535 where close c = c == '}' || c == '\n' -- don't span newlines
1539 lookupEnvVar :: String -> IO String
1540 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1541 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1543 catchIO (System.Environment.getEnv nm)
1544 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1548 -----------------------------------------------------------------------------
1550 getProgramName :: IO String
1551 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1552 where str `withoutSuffix` suff
1553 | suff `isSuffixOf` str = take (length str - length suff) str
1556 bye :: String -> IO a
1557 bye s = putStr s >> exitWith ExitSuccess
1559 die :: String -> IO a
1562 dieWith :: Int -> String -> IO a
1565 prog <- getProgramName
1566 hPutStrLn stderr (prog ++ ": " ++ s)
1567 exitWith (ExitFailure ec)
1569 dieOrForceAll :: Force -> String -> IO ()
1570 dieOrForceAll ForceAll s = ignoreError s
1571 dieOrForceAll _other s = dieForcible s
1573 warn :: String -> IO ()
1576 ignoreError :: String -> IO ()
1577 ignoreError s = reportError (s ++ " (ignoring)")
1579 reportError :: String -> IO ()
1580 reportError s = do hFlush stdout; hPutStrLn stderr s
1582 dieForcible :: String -> IO ()
1583 dieForcible s = die (s ++ " (use --force to override)")
1585 my_head :: String -> [a] -> a
1586 my_head s [] = error s
1587 my_head _ (x : _) = x
1589 -----------------------------------------
1590 -- Cut and pasted from ghc/compiler/main/SysTools
1592 #if defined(mingw32_HOST_OS)
1593 subst :: Char -> Char -> String -> String
1594 subst a b ls = map (\ x -> if x == a then b else x) ls
1596 unDosifyPath :: FilePath -> FilePath
1597 unDosifyPath xs = subst '\\' '/' xs
1599 getLibDir :: IO (Maybe String)
1600 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1602 -- (getExecDir cmd) returns the directory in which the current
1603 -- executable, which should be called 'cmd', is running
1604 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1605 -- you'll get "/a/b/c" back as the result
1606 getExecDir :: String -> IO (Maybe String)
1608 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1609 where initN n = reverse . drop n . reverse
1610 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1612 getExecPath :: IO (Maybe String)
1613 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1615 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1616 ret <- c_GetModuleFileName nullPtr buf size
1619 _ | ret < size -> fmap Just $ peekCWString buf
1620 | otherwise -> try_size (size * 2)
1622 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
1623 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1625 getLibDir :: IO (Maybe String)
1626 getLibDir = return Nothing
1629 -----------------------------------------
1630 -- Adapted from ghc/compiler/utils/Panic
1632 installSignalHandlers :: IO ()
1633 installSignalHandlers = do
1634 threadid <- myThreadId
1636 interrupt = Exception.throwTo threadid
1637 (Exception.ErrorCall "interrupted")
1639 #if !defined(mingw32_HOST_OS)
1640 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1641 _ <- installHandler sigINT (Catch interrupt) Nothing
1644 -- GHC 6.3+ has support for console events on Windows
1645 -- NOTE: running GHCi under a bash shell for some reason requires
1646 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1647 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1648 -- why --SDM 17/12/2004
1649 let sig_handler ControlC = interrupt
1650 sig_handler Break = interrupt
1651 sig_handler _ = return ()
1653 _ <- installHandler (Catch sig_handler)
1657 #if mingw32_HOST_OS || mingw32_TARGET_OS
1658 throwIOIO :: Exception.IOException -> IO a
1659 throwIOIO = Exception.throwIO
1662 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1663 catchIO = Exception.catch
1665 catchError :: IO a -> (String -> IO a) -> IO a
1666 catchError io handler = io `Exception.catch` handler'
1667 where handler' (Exception.ErrorCall err) = handler err
1669 tryIO :: IO a -> IO (Either Exception.IOException a)
1670 tryIO = Exception.try
1672 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1673 writeBinaryFileAtomic targetFile obj =
1674 withFileAtomic targetFile $ \h -> do
1675 hSetBinaryMode h True
1676 B.hPutStr h (Bin.encode obj)
1678 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1679 writeFileUtf8Atomic targetFile content =
1680 withFileAtomic targetFile $ \h -> do
1684 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1685 -- to use text files here, rather than binary files.
1686 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1687 withFileAtomic targetFile write_content = do
1688 (newFile, newHandle) <- openNewFile targetDir template
1689 do write_content newHandle
1691 #if mingw32_HOST_OS || mingw32_TARGET_OS
1692 renameFile newFile targetFile
1693 -- If the targetFile exists then renameFile will fail
1694 `catchIO` \err -> do
1695 exists <- doesFileExist targetFile
1697 then do removeFileSafe targetFile
1698 -- Big fat hairy race condition
1699 renameFile newFile targetFile
1700 -- If the removeFile succeeds and the renameFile fails
1701 -- then we've lost the atomic property.
1704 renameFile newFile targetFile
1706 `Exception.onException` do hClose newHandle
1707 removeFileSafe newFile
1709 template = targetName <.> "tmp"
1710 targetDir | null targetDir_ = "."
1711 | otherwise = targetDir_
1712 --TODO: remove this when takeDirectory/splitFileName is fixed
1713 -- to always return a valid dir
1714 (targetDir_,targetName) = splitFileName targetFile
1716 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1717 openNewFile dir template = do
1718 -- this was added to System.IO in 6.12.1
1719 -- we must use this version because the version below opens the file
1721 openTempFileWithDefaultPermissions dir template
1723 -- | The function splits the given string to substrings
1724 -- using 'isSearchPathSeparator'.
1725 parseSearchPath :: String -> [FilePath]
1726 parseSearchPath path = split path
1728 split :: String -> [String]
1732 _:rest -> chunk : split rest
1736 #ifdef mingw32_HOST_OS
1737 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1741 (chunk', rest') = break isSearchPathSeparator s
1743 readUTF8File :: FilePath -> IO String
1744 readUTF8File file = do
1745 h <- openFile file ReadMode
1746 -- fix the encoding to UTF-8
1750 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1751 removeFileSafe :: FilePath -> IO ()
1753 removeFile fn `catchIO` \ e ->
1754 when (not $ isDoesNotExistError e) $ ioError e
1756 absolutePath :: FilePath -> IO FilePath
1757 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory