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 -- haddock-html is allowed to be either a URL or a file
682 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
685 munge_paths = map munge_path
686 munge_urls = map munge_url
689 | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
690 | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
696 | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
697 | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
702 toUrlPath r p = "file:///"
703 -- URLs always use posix style '/' separators:
704 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
706 stripVarPrefix var (root:path')
707 | Just [sep] <- stripPrefix var root
708 , isPathSeparator sep
709 = Just (joinPath path')
711 stripVarPrefix _ _ = Nothing
714 -- -----------------------------------------------------------------------------
715 -- Creating a new package DB
717 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
718 initPackageDB filename verbosity _flags = do
719 let eexist = die ("cannot create: " ++ filename ++ " already exists")
720 b1 <- doesFileExist filename
722 b2 <- doesDirectoryExist filename
724 filename_abs <- absolutePath filename
725 changeDB verbosity [] PackageDB {
726 location = filename, locationAbsolute = filename_abs,
730 -- -----------------------------------------------------------------------------
733 registerPackage :: FilePath
736 -> Bool -- auto_ghci_libs
737 -> Bool -- expand_env_vars
741 registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
742 (db_stack, Just to_modify, _flag_dbs) <-
743 getPkgDatabases verbosity True True False{-expand vars-} my_flags
746 db_to_operate_on = my_head "register" $
747 filter ((== to_modify).location) db_stack
749 when (auto_ghci_libs && verbosity >= Silent) $
750 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
755 when (verbosity >= Normal) $
756 putStr "Reading package info from stdin ... "
757 -- fix the encoding to UTF-8, since this is an interchange format
758 hSetEncoding stdin utf8
761 when (verbosity >= Normal) $
762 putStr ("Reading package info from " ++ show f ++ " ... ")
765 expanded <- if expand_env_vars then expandEnvVars s force
768 (pkg, ws) <- parsePackageInfo expanded
769 when (verbosity >= Normal) $
772 -- report any warnings from the parse phase
773 _ <- reportValidateErrors [] ws
774 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
776 -- validate the expanded pkg, but register the unexpanded
777 pkgroot <- absolutePath (takeDirectory to_modify)
778 let top_dir = takeDirectory (location (last db_stack))
779 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
781 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
782 -- truncate the stack for validation, because we don't allow
783 -- packages lower in the stack to refer to those higher up.
784 validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
786 removes = [ RemovePackage p
787 | p <- packages db_to_operate_on,
788 sourcePackageId p == sourcePackageId pkg ]
790 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
794 -> IO (InstalledPackageInfo, [ValidateWarning])
795 parsePackageInfo str =
796 case parseInstalledPackageInfo str of
797 ParseOk warnings ok -> return (ok, ws)
799 ws = [ msg | PWarning msg <- warnings
800 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
801 ParseFailed err -> case locatedErrorMsg err of
802 (Nothing, s) -> die s
803 (Just l, s) -> die (show l ++ ": " ++ s)
805 -- -----------------------------------------------------------------------------
806 -- Making changes to a package database
808 data DBOp = RemovePackage InstalledPackageInfo
809 | AddPackage InstalledPackageInfo
810 | ModifyPackage InstalledPackageInfo
812 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
813 changeDB verbosity cmds db = do
814 let db' = updateInternalDB db cmds
815 isfile <- doesFileExist (location db)
817 then writeNewConfig verbosity (location db') (packages db')
819 createDirectoryIfMissing True (location db)
820 changeDBDir verbosity cmds db'
822 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
823 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
825 do_cmd pkgs (RemovePackage p) =
826 filter ((/= installedPackageId p) . installedPackageId) pkgs
827 do_cmd pkgs (AddPackage p) = p : pkgs
828 do_cmd pkgs (ModifyPackage p) =
829 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
832 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
833 changeDBDir verbosity cmds db = do
835 updateDBCache verbosity db
837 do_cmd (RemovePackage p) = do
838 let file = location db </> display (installedPackageId p) <.> "conf"
839 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
841 do_cmd (AddPackage p) = do
842 let file = location db </> display (installedPackageId p) <.> "conf"
843 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
844 writeFileUtf8Atomic file (showInstalledPackageInfo p)
845 do_cmd (ModifyPackage p) =
846 do_cmd (AddPackage p)
848 updateDBCache :: Verbosity -> PackageDB -> IO ()
849 updateDBCache verbosity db = do
850 let filename = location db </> cachefilename
851 when (verbosity > Normal) $
852 putStrLn ("writing cache " ++ filename)
853 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
855 if isPermissionError e
856 then die (filename ++ ": you don't have permission to modify this file")
859 -- -----------------------------------------------------------------------------
860 -- Exposing, Hiding, Unregistering are all similar
862 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
863 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
865 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
866 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
868 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
869 unregisterPackage = modifyPackage RemovePackage
872 :: (InstalledPackageInfo -> DBOp)
878 modifyPackage fn pkgid verbosity my_flags force = do
879 (db_stack, Just _to_modify, _flag_dbs) <-
880 getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
882 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
884 db_name = location db
887 pids = map sourcePackageId ps
889 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
890 new_db = updateInternalDB db cmds
892 old_broken = brokenPackages (allPackagesInStack db_stack)
893 rest_of_stack = filter ((/= db_name) . location) db_stack
894 new_stack = new_db : rest_of_stack
895 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
896 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
898 when (not (null newly_broken)) $
899 dieOrForceAll force ("unregistering " ++ display pkgid ++
900 " would break the following packages: "
901 ++ unwords (map display newly_broken))
903 changeDB verbosity cmds db
905 recache :: Verbosity -> [Flag] -> IO ()
906 recache verbosity my_flags = do
907 (db_stack, Just to_modify, _flag_dbs) <-
908 getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
910 db_to_operate_on = my_head "recache" $
911 filter ((== to_modify).location) db_stack
913 changeDB verbosity [] db_to_operate_on
915 -- -----------------------------------------------------------------------------
918 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
919 -> Maybe (String->Bool)
921 listPackages verbosity my_flags mPackageName mModuleName = do
922 let simple_output = FlagSimpleOutput `elem` my_flags
923 (db_stack, _, flag_db_stack) <-
924 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
926 let db_stack_filtered -- if a package is given, filter out all other packages
927 | Just this <- mPackageName =
928 [ db{ packages = filter (this `matchesPkg`) (packages db) }
929 | db <- flag_db_stack ]
930 | Just match <- mModuleName = -- packages which expose mModuleName
931 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
932 | db <- flag_db_stack ]
933 | otherwise = flag_db_stack
936 = [ db{ packages = sort_pkgs (packages db) }
937 | db <- db_stack_filtered ]
938 where sort_pkgs = sortBy cmpPkgIds
939 cmpPkgIds pkg1 pkg2 =
940 case pkgName p1 `compare` pkgName p2 of
943 EQ -> pkgVersion p1 `compare` pkgVersion p2
944 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
946 stack = reverse db_stack_sorted
948 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
950 pkg_map = allPackagesInStack db_stack
951 broken = map sourcePackageId (brokenPackages pkg_map)
953 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
954 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
956 pp_pkgs = map pp_pkg pkg_confs
958 | sourcePackageId p `elem` broken = printf "{%s}" doc
960 | otherwise = printf "(%s)" doc
961 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
964 InstalledPackageId ipid = installedPackageId p
965 pkg = display (sourcePackageId p)
967 show_simple = simplePackageList my_flags . allPackagesInStack
969 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
970 prog <- getProgramName
971 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
973 if simple_output then show_simple stack else do
975 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
976 mapM_ show_normal stack
979 show_colour withF db =
980 mconcat $ map (<#> termText "\n") $
981 (termText (location db) :
982 map (termText " " <#>) (map pp_pkg (packages db)))
985 | sourcePackageId p `elem` broken = withF Red doc
987 | otherwise = withF Blue doc
988 where doc | verbosity >= Verbose
989 = termText (printf "%s (%s)" pkg ipid)
993 InstalledPackageId ipid = installedPackageId p
994 pkg = display (sourcePackageId p)
996 is_tty <- hIsTerminalDevice stdout
998 then mapM_ show_normal stack
999 else do tty <- Terminfo.setupTermFromEnv
1000 case Terminfo.getCapability tty withForegroundColor of
1001 Nothing -> mapM_ show_normal stack
1002 Just w -> runTermOutput tty $ mconcat $
1003 map (show_colour w) stack
1006 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1007 simplePackageList my_flags pkgs = do
1008 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1010 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
1011 when (not (null pkgs)) $
1012 hPutStrLn stdout $ concat $ intersperse " " strs
1014 showPackageDot :: Verbosity -> [Flag] -> IO ()
1015 showPackageDot verbosity myflags = do
1016 (_, _, flag_db_stack) <-
1017 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
1019 let all_pkgs = allPackagesInStack flag_db_stack
1020 ipix = PackageIndex.fromList all_pkgs
1022 putStrLn "digraph {"
1023 let quote s = '"':s ++ "\""
1024 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1026 let from = display (sourcePackageId p),
1028 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1029 let to = display (sourcePackageId dep)
1033 -- -----------------------------------------------------------------------------
1034 -- Prints the highest (hidden or exposed) version of a package
1036 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1037 latestPackage verbosity my_flags pkgid = do
1038 (_, _, flag_db_stack) <-
1039 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1041 ps <- findPackages flag_db_stack (Id pkgid)
1042 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
1044 show_pkg [] = die "no matches"
1045 show_pkg pids = hPutStrLn stdout (display (last pids))
1047 -- -----------------------------------------------------------------------------
1050 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1051 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1052 (_, _, flag_db_stack) <-
1053 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1054 dbs <- findPackagesByDB flag_db_stack pkgarg
1055 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1056 | (db, pkgs) <- dbs, pkg <- pkgs ]
1058 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1059 dumpPackages verbosity my_flags expand_pkgroot = do
1060 (_, _, flag_db_stack) <-
1061 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1062 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1063 | db <- flag_db_stack, pkg <- packages db ]
1065 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1066 doDump expand_pkgroot pkgs = do
1067 -- fix the encoding to UTF-8, since this is an interchange format
1068 hSetEncoding stdout utf8
1072 then showInstalledPackageInfo pkg
1073 else showInstalledPackageInfo pkg ++ pkgrootField
1074 | (pkg, pkgloc) <- pkgs
1075 , let pkgroot = takeDirectory pkgloc
1076 pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
1078 -- PackageId is can have globVersion for the version
1079 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1080 findPackages db_stack pkgarg
1081 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1083 findPackagesByDB :: PackageDBStack -> PackageArg
1084 -> IO [(PackageDB, [InstalledPackageInfo])]
1085 findPackagesByDB db_stack pkgarg
1086 = case [ (db, matched)
1088 let matched = filter (pkgarg `matchesPkg`) (packages db),
1089 not (null matched) ] of
1090 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1093 pkg_msg (Id pkgid) = display pkgid
1094 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1096 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1098 = (pkgName pid == pkgName pid')
1099 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1101 realVersion :: PackageIdentifier -> Bool
1102 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1103 -- when versionBranch == [], this is a glob
1105 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1106 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1107 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1109 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
1110 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
1112 -- -----------------------------------------------------------------------------
1115 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1116 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1117 (_, _, flag_db_stack) <-
1118 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1119 fns <- toFields fields
1120 ps <- findPackages flag_db_stack pkgarg
1121 mapM_ (selectFields fns) ps
1122 where toFields [] = return []
1123 toFields (f:fs) = case toField f of
1124 Nothing -> die ("unknown field: " ++ f)
1125 Just fn -> do fns <- toFields fs
1127 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1129 toField :: String -> Maybe (InstalledPackageInfo -> String)
1130 -- backwards compatibility:
1131 toField "import_dirs" = Just $ strList . importDirs
1132 toField "source_dirs" = Just $ strList . importDirs
1133 toField "library_dirs" = Just $ strList . libraryDirs
1134 toField "hs_libraries" = Just $ strList . hsLibraries
1135 toField "extra_libraries" = Just $ strList . extraLibraries
1136 toField "include_dirs" = Just $ strList . includeDirs
1137 toField "c_includes" = Just $ strList . includes
1138 toField "package_deps" = Just $ strList . map display. depends
1139 toField "extra_cc_opts" = Just $ strList . ccOptions
1140 toField "extra_ld_opts" = Just $ strList . ldOptions
1141 toField "framework_dirs" = Just $ strList . frameworkDirs
1142 toField "extra_frameworks"= Just $ strList . frameworks
1143 toField s = showInstalledPackageInfoField s
1145 strList :: [String] -> String
1149 -- -----------------------------------------------------------------------------
1150 -- Check: Check consistency of installed packages
1152 checkConsistency :: Verbosity -> [Flag] -> IO ()
1153 checkConsistency verbosity my_flags = do
1155 getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
1156 -- check behaves like modify for the purposes of deciding which
1157 -- databases to use, because ordering is important.
1159 let simple_output = FlagSimpleOutput `elem` my_flags
1161 let pkgs = allPackagesInStack db_stack
1164 (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1166 then do when (not simple_output) $ do
1167 _ <- reportValidateErrors [] ws "" Nothing
1171 when (not simple_output) $ do
1172 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1173 _ <- reportValidateErrors es ws " " Nothing
1177 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1179 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1180 where not_in p = sourcePackageId p `notElem` all_ps
1181 all_ps = map sourcePackageId pkgs1
1183 let not_broken_pkgs = filterOut broken_pkgs pkgs
1184 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1185 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1187 when (not (null all_broken_pkgs)) $ do
1189 then simplePackageList my_flags all_broken_pkgs
1191 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1192 "listed above, or because they depend on a broken package.")
1193 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1195 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1198 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1199 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1200 closure pkgs db_stack = go pkgs db_stack
1202 go avail not_avail =
1203 case partition (depsAvailable avail) not_avail of
1204 ([], not_avail') -> (avail, not_avail')
1205 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1207 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1209 depsAvailable pkgs_ok pkg = null dangling
1210 where dangling = filter (`notElem` pids) (depends pkg)
1211 pids = map installedPackageId pkgs_ok
1213 -- we want mutually recursive groups of package to show up
1214 -- as broken. (#1750)
1216 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1217 brokenPackages pkgs = snd (closure [] pkgs)
1219 -- -----------------------------------------------------------------------------
1220 -- Manipulating package.conf files
1222 type InstalledPackageInfoString = InstalledPackageInfo_ String
1224 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1225 convertPackageInfoOut
1226 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1227 hiddenModules = h })) =
1228 pkgconf{ exposedModules = map display e,
1229 hiddenModules = map display h }
1231 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1232 convertPackageInfoIn
1233 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1234 hiddenModules = h })) =
1235 pkgconf{ exposedModules = map convert e,
1236 hiddenModules = map convert h }
1237 where convert = fromJust . simpleParse
1239 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1240 writeNewConfig verbosity filename ipis = do
1241 when (verbosity >= Normal) $
1242 hPutStr stdout "Writing new package config file... "
1243 createDirectoryIfMissing True $ takeDirectory filename
1244 let shown = concat $ intersperse ",\n "
1245 $ map (show . convertPackageInfoOut) ipis
1246 fileContents = "[" ++ shown ++ "\n]"
1247 writeFileUtf8Atomic filename fileContents
1249 if isPermissionError e
1250 then die (filename ++ ": you don't have permission to modify this file")
1252 when (verbosity >= Normal) $
1253 hPutStrLn stdout "done."
1255 -----------------------------------------------------------------------------
1256 -- Sanity-check a new package config, and automatically build GHCi libs
1259 type ValidateError = (Force,String)
1260 type ValidateWarning = String
1262 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1264 instance Monad Validate where
1265 return a = V $ return (a, [], [])
1267 (a, es, ws) <- runValidate m
1268 (b, es', ws') <- runValidate (k a)
1269 return (b,es++es',ws++ws')
1271 verror :: Force -> String -> Validate ()
1272 verror f s = V (return ((),[(f,s)],[]))
1274 vwarn :: String -> Validate ()
1275 vwarn s = V (return ((),[],["Warning: " ++ s]))
1277 liftIO :: IO a -> Validate a
1278 liftIO k = V (k >>= \a -> return (a,[],[]))
1280 -- returns False if we should die
1281 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1282 -> String -> Maybe Force -> IO Bool
1283 reportValidateErrors es ws prefix mb_force = do
1284 mapM_ (warn . (prefix++)) ws
1285 oks <- mapM report es
1289 | Just force <- mb_force
1291 then do reportError (prefix ++ s ++ " (ignoring)")
1293 else if f < CannotForce
1294 then do reportError (prefix ++ s ++ " (use --force to override)")
1296 else do reportError err
1298 | otherwise = do reportError err
1303 validatePackageConfig :: InstalledPackageInfo
1305 -> Bool -- auto-ghc-libs
1306 -> Bool -- update, or check
1309 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1310 (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1311 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1312 when (not ok) $ exitWith (ExitFailure 1)
1314 checkPackageConfig :: InstalledPackageInfo
1316 -> Bool -- auto-ghc-libs
1317 -> Bool -- update, or check
1319 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1320 checkInstalledPackageId pkg db_stack update
1322 checkDuplicates db_stack pkg update
1323 mapM_ (checkDep db_stack) (depends pkg)
1324 checkDuplicateDepends (depends pkg)
1325 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1326 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1327 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1328 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1329 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1330 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1332 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1333 -- ToDo: check these somehow?
1334 -- extra_libraries :: [String],
1335 -- c_includes :: [String],
1337 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1339 checkInstalledPackageId ipi db_stack update = do
1340 let ipid@(InstalledPackageId str) = installedPackageId ipi
1341 when (null str) $ verror CannotForce "missing id field"
1342 let dups = [ p | p <- allPackagesInStack db_stack,
1343 installedPackageId p == ipid ]
1344 when (not update && not (null dups)) $
1345 verror CannotForce $
1346 "package(s) with this id already exist: " ++
1347 unwords (map (display.packageId) dups)
1349 -- When the package name and version are put together, sometimes we can
1350 -- end up with a package id that cannot be parsed. This will lead to
1351 -- difficulties when the user wants to refer to the package later, so
1352 -- we check that the package id can be parsed properly here.
1353 checkPackageId :: InstalledPackageInfo -> Validate ()
1354 checkPackageId ipi =
1355 let str = display (sourcePackageId ipi) in
1356 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1358 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1359 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1361 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1362 checkDuplicates db_stack pkg update = do
1364 pkgid = sourcePackageId pkg
1365 pkgs = packages (head db_stack)
1367 -- Check whether this package id already exists in this DB
1369 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1370 verror CannotForce $
1371 "package " ++ display pkgid ++ " is already installed"
1374 uncasep = map toLower . display
1375 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1377 when (not update && not (null dups)) $ verror ForceAll $
1378 "Package names may be treated case-insensitively in the future.\n"++
1379 "Package " ++ display pkgid ++
1380 " overlaps with: " ++ unwords (map display dups)
1382 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1383 checkDir = checkPath False True
1384 checkFile = checkPath False False
1385 checkDirURL = checkPath True True
1387 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1388 checkPath url_ok is_dir warn_only thisfield d
1389 | url_ok && ("http://" `isPrefixOf` d
1390 || "https://" `isPrefixOf` d) = return ()
1393 , Just d' <- stripPrefix "file://" d
1394 = checkPath False is_dir warn_only thisfield d'
1396 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1397 -- variables having been expanded already, see mungePackagePaths.
1399 | isRelative d = verror ForceFiles $
1400 thisfield ++ ": " ++ d ++ " is a relative path which "
1401 ++ "makes no sense (as there is nothing for it to be "
1402 ++ "relative to). You can make paths relative to the "
1403 ++ "package database itself by using ${pkgroot}."
1404 -- relative paths don't make any sense; #4134
1406 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1408 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1409 ++ if is_dir then "directory" else "file"
1413 else verror ForceFiles msg
1415 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1416 checkDep db_stack pkgid
1417 | pkgid `elem` pkgids = return ()
1418 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1419 ++ "\" doesn't exist")
1421 all_pkgs = allPackagesInStack db_stack
1422 pkgids = map installedPackageId all_pkgs
1424 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1425 checkDuplicateDepends deps
1426 | null dups = return ()
1427 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1428 unwords (map display dups))
1430 dups = [ p | (p:_:_) <- group (sort deps) ]
1432 checkHSLib :: [String] -> Bool -> String -> Validate ()
1433 checkHSLib dirs auto_ghci_libs lib = do
1434 let batch_lib_file = "lib" ++ lib ++ ".a"
1435 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1437 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1439 Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
1441 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1442 doesFileExistOnPath file path = go path
1443 where go [] = return Nothing
1444 go (p:ps) = do b <- doesFileExistIn file p
1445 if b then return (Just p) else go ps
1447 doesFileExistIn :: String -> String -> IO Bool
1448 doesFileExistIn lib d = doesFileExist (d </> lib)
1450 checkModules :: InstalledPackageInfo -> Validate ()
1451 checkModules pkg = do
1452 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1454 findModule modl = do
1455 -- there's no .hi file for GHC.Prim
1456 if modl == fromString "GHC.Prim" then return () else do
1457 let file = toFilePath modl <.> "hi"
1458 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1459 when (isNothing m) $
1460 verror ForceFiles ("file " ++ file ++ " is missing")
1462 checkGHCiLib :: String -> String -> String -> Bool -> IO ()
1463 checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
1464 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1465 | otherwise = return ()
1467 ghci_lib_file = lib <.> "o"
1469 -- automatically build the GHCi version of a batch lib,
1470 -- using ld --whole-archive.
1472 autoBuildGHCiLib :: String -> String -> String -> IO ()
1473 autoBuildGHCiLib dir batch_file ghci_file = do
1474 let ghci_lib_file = dir ++ '/':ghci_file
1475 batch_lib_file = dir ++ '/':batch_file
1476 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1477 #if defined(darwin_HOST_OS)
1478 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1479 #elif defined(mingw32_HOST_OS)
1480 execDir <- getLibDir
1481 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1483 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1485 when (r /= ExitSuccess) $ exitWith r
1486 hPutStrLn stderr (" done.")
1488 -- -----------------------------------------------------------------------------
1489 -- Searching for modules
1493 findModules :: [FilePath] -> IO [String]
1495 mms <- mapM searchDir paths
1498 searchDir path prefix = do
1499 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1500 searchEntries path prefix fs
1502 searchEntries path prefix [] = return []
1503 searchEntries path prefix (f:fs)
1504 | looks_like_a_module = do
1505 ms <- searchEntries path prefix fs
1506 return (prefix `joinModule` f : ms)
1507 | looks_like_a_component = do
1508 ms <- searchDir (path </> f) (prefix `joinModule` f)
1509 ms' <- searchEntries path prefix fs
1512 searchEntries path prefix fs
1515 (base,suffix) = splitFileExt f
1516 looks_like_a_module =
1517 suffix `elem` haskell_suffixes &&
1518 all okInModuleName base
1519 looks_like_a_component =
1520 null suffix && all okInModuleName base
1526 -- ---------------------------------------------------------------------------
1527 -- expanding environment variables in the package configuration
1529 expandEnvVars :: String -> Force -> IO String
1530 expandEnvVars str0 force = go str0 ""
1532 go "" acc = return $! reverse acc
1533 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1534 = do value <- lookupEnvVar var
1535 go rest (reverse value ++ acc)
1536 where close c = c == '}' || c == '\n' -- don't span newlines
1540 lookupEnvVar :: String -> IO String
1541 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1542 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1544 catchIO (System.Environment.getEnv nm)
1545 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1549 -----------------------------------------------------------------------------
1551 getProgramName :: IO String
1552 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1553 where str `withoutSuffix` suff
1554 | suff `isSuffixOf` str = take (length str - length suff) str
1557 bye :: String -> IO a
1558 bye s = putStr s >> exitWith ExitSuccess
1560 die :: String -> IO a
1563 dieWith :: Int -> String -> IO a
1566 prog <- getProgramName
1567 hPutStrLn stderr (prog ++ ": " ++ s)
1568 exitWith (ExitFailure ec)
1570 dieOrForceAll :: Force -> String -> IO ()
1571 dieOrForceAll ForceAll s = ignoreError s
1572 dieOrForceAll _other s = dieForcible s
1574 warn :: String -> IO ()
1577 ignoreError :: String -> IO ()
1578 ignoreError s = reportError (s ++ " (ignoring)")
1580 reportError :: String -> IO ()
1581 reportError s = do hFlush stdout; hPutStrLn stderr s
1583 dieForcible :: String -> IO ()
1584 dieForcible s = die (s ++ " (use --force to override)")
1586 my_head :: String -> [a] -> a
1587 my_head s [] = error s
1588 my_head _ (x : _) = x
1590 -----------------------------------------
1591 -- Cut and pasted from ghc/compiler/main/SysTools
1593 #if defined(mingw32_HOST_OS)
1594 subst :: Char -> Char -> String -> String
1595 subst a b ls = map (\ x -> if x == a then b else x) ls
1597 unDosifyPath :: FilePath -> FilePath
1598 unDosifyPath xs = subst '\\' '/' xs
1600 getLibDir :: IO (Maybe String)
1601 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1603 -- (getExecDir cmd) returns the directory in which the current
1604 -- executable, which should be called 'cmd', is running
1605 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1606 -- you'll get "/a/b/c" back as the result
1607 getExecDir :: String -> IO (Maybe String)
1609 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1610 where initN n = reverse . drop n . reverse
1611 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1613 getExecPath :: IO (Maybe String)
1614 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1616 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1617 ret <- c_GetModuleFileName nullPtr buf size
1620 _ | ret < size -> fmap Just $ peekCWString buf
1621 | otherwise -> try_size (size * 2)
1623 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
1624 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1626 getLibDir :: IO (Maybe String)
1627 getLibDir = return Nothing
1630 -----------------------------------------
1631 -- Adapted from ghc/compiler/utils/Panic
1633 installSignalHandlers :: IO ()
1634 installSignalHandlers = do
1635 threadid <- myThreadId
1637 interrupt = Exception.throwTo threadid
1638 (Exception.ErrorCall "interrupted")
1640 #if !defined(mingw32_HOST_OS)
1641 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1642 _ <- installHandler sigINT (Catch interrupt) Nothing
1645 -- GHC 6.3+ has support for console events on Windows
1646 -- NOTE: running GHCi under a bash shell for some reason requires
1647 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1648 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1649 -- why --SDM 17/12/2004
1650 let sig_handler ControlC = interrupt
1651 sig_handler Break = interrupt
1652 sig_handler _ = return ()
1654 _ <- installHandler (Catch sig_handler)
1658 #if mingw32_HOST_OS || mingw32_TARGET_OS
1659 throwIOIO :: Exception.IOException -> IO a
1660 throwIOIO = Exception.throwIO
1663 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1664 catchIO = Exception.catch
1666 catchError :: IO a -> (String -> IO a) -> IO a
1667 catchError io handler = io `Exception.catch` handler'
1668 where handler' (Exception.ErrorCall err) = handler err
1670 tryIO :: IO a -> IO (Either Exception.IOException a)
1671 tryIO = Exception.try
1673 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1674 writeBinaryFileAtomic targetFile obj =
1675 withFileAtomic targetFile $ \h -> do
1676 hSetBinaryMode h True
1677 B.hPutStr h (Bin.encode obj)
1679 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1680 writeFileUtf8Atomic targetFile content =
1681 withFileAtomic targetFile $ \h -> do
1685 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1686 -- to use text files here, rather than binary files.
1687 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1688 withFileAtomic targetFile write_content = do
1689 (newFile, newHandle) <- openNewFile targetDir template
1690 do write_content newHandle
1692 #if mingw32_HOST_OS || mingw32_TARGET_OS
1693 renameFile newFile targetFile
1694 -- If the targetFile exists then renameFile will fail
1695 `catchIO` \err -> do
1696 exists <- doesFileExist targetFile
1698 then do removeFileSafe targetFile
1699 -- Big fat hairy race condition
1700 renameFile newFile targetFile
1701 -- If the removeFile succeeds and the renameFile fails
1702 -- then we've lost the atomic property.
1705 renameFile newFile targetFile
1707 `Exception.onException` do hClose newHandle
1708 removeFileSafe newFile
1710 template = targetName <.> "tmp"
1711 targetDir | null targetDir_ = "."
1712 | otherwise = targetDir_
1713 --TODO: remove this when takeDirectory/splitFileName is fixed
1714 -- to always return a valid dir
1715 (targetDir_,targetName) = splitFileName targetFile
1717 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1718 openNewFile dir template = do
1719 -- this was added to System.IO in 6.12.1
1720 -- we must use this version because the version below opens the file
1722 openTempFileWithDefaultPermissions dir template
1724 -- | The function splits the given string to substrings
1725 -- using 'isSearchPathSeparator'.
1726 parseSearchPath :: String -> [FilePath]
1727 parseSearchPath path = split path
1729 split :: String -> [String]
1733 _:rest -> chunk : split rest
1737 #ifdef mingw32_HOST_OS
1738 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1742 (chunk', rest') = break isSearchPathSeparator s
1744 readUTF8File :: FilePath -> IO String
1745 readUTF8File file = do
1746 h <- openFile file ReadMode
1747 -- fix the encoding to UTF-8
1751 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1752 removeFileSafe :: FilePath -> IO ()
1754 removeFile fn `catchIO` \ e ->
1755 when (not $ isDoesNotExistError e) $ ioError e
1757 absolutePath :: FilePath -> IO FilePath
1758 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory