Improve the ghc-pkg warnings for missing and out of date package cache files
[ghc.git] / utils / ghc-pkg / Main.hs
1 {-# LANGUAGE CPP #-}
2 -----------------------------------------------------------------------------
3 --
4 -- (c) The University of Glasgow 2004-2009.
5 --
6 -- Package management tool
7 --
8 -----------------------------------------------------------------------------
9
10 module Main (main) where
11
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.ModuleExport
20 import Distribution.Package hiding (depends)
21 import Distribution.Text
22 import Distribution.Version
23 import System.FilePath as FilePath
24 import qualified System.FilePath.Posix as FilePath.Posix
25 import System.Process
26 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
27 getModificationTime )
28 import Text.Printf
29
30 import Prelude
31
32 import System.Console.GetOpt
33 import qualified Control.Exception as Exception
34 import Data.Maybe
35
36 import qualified Data.Set as Set
37
38 import Data.Char ( isSpace, toLower )
39 import Data.Ord (comparing)
40 import Control.Applicative (Applicative(..))
41 import Control.Monad
42 import System.Directory ( doesDirectoryExist, getDirectoryContents,
43 doesFileExist, renameFile, removeFile,
44 getCurrentDirectory )
45 import System.Exit ( exitWith, ExitCode(..) )
46 import System.Environment ( getArgs, getProgName, getEnv )
47 import System.IO
48 import System.IO.Error
49 import GHC.IO.Exception (IOErrorType(InappropriateType))
50 import Data.List
51 import Control.Concurrent
52
53 import qualified Data.ByteString.Lazy as B
54 import qualified Data.Binary as Bin
55 import qualified Data.Binary.Get as Bin
56
57 #if defined(mingw32_HOST_OS)
58 -- mingw32 needs these for getExecDir
59 import Foreign
60 import Foreign.C
61 #endif
62
63 #ifdef mingw32_HOST_OS
64 import GHC.ConsoleHandler
65 #else
66 import System.Posix hiding (fdToHandle)
67 #endif
68
69 #if defined(GLOB)
70 import qualified System.Info(os)
71 #endif
72
73 #if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
74 import System.Console.Terminfo as Terminfo
75 #endif
76
77 #ifdef mingw32_HOST_OS
78 # if defined(i386_HOST_ARCH)
79 # define WINDOWS_CCONV stdcall
80 # elif defined(x86_64_HOST_ARCH)
81 # define WINDOWS_CCONV ccall
82 # else
83 # error Unknown mingw32 arch
84 # endif
85 #endif
86
87 -- -----------------------------------------------------------------------------
88 -- Entry point
89
90 main :: IO ()
91 main = do
92 args <- getArgs
93
94 case getOpt Permute (flags ++ deprecFlags) args of
95 (cli,_,[]) | FlagHelp `elem` cli -> do
96 prog <- getProgramName
97 bye (usageInfo (usageHeader prog) flags)
98 (cli,_,[]) | FlagVersion `elem` cli ->
99 bye ourCopyright
100 (cli,nonopts,[]) ->
101 case getVerbosity Normal cli of
102 Right v -> runit v cli nonopts
103 Left err -> die err
104 (_,_,errors) -> do
105 prog <- getProgramName
106 die (concat errors ++ shortUsage prog)
107
108 -- -----------------------------------------------------------------------------
109 -- Command-line syntax
110
111 data Flag
112 = FlagUser
113 | FlagGlobal
114 | FlagHelp
115 | FlagVersion
116 | FlagConfig FilePath
117 | FlagGlobalConfig FilePath
118 | FlagUserConfig FilePath
119 | FlagForce
120 | FlagForceFiles
121 | FlagAutoGHCiLibs
122 | FlagMultiInstance
123 | FlagExpandEnvVars
124 | FlagExpandPkgroot
125 | FlagNoExpandPkgroot
126 | FlagSimpleOutput
127 | FlagNamesOnly
128 | FlagIgnoreCase
129 | FlagNoUserDb
130 | FlagVerbosity (Maybe String)
131 | FlagIPId
132 deriving Eq
133
134 flags :: [OptDescr Flag]
135 flags = [
136 Option [] ["user"] (NoArg FlagUser)
137 "use the current user's package database",
138 Option [] ["global"] (NoArg FlagGlobal)
139 "use the global package database",
140 Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")
141 "use the specified package database",
142 Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")
143 "use the specified package database (DEPRECATED)",
144 Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")
145 "location of the global package database",
146 Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
147 "never read the user package database",
148 Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR")
149 "location of the user package database (use instead of default)",
150 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
151 "never read the user package database (DEPRECATED)",
152 Option [] ["force"] (NoArg FlagForce)
153 "ignore missing dependencies, directories, and libraries",
154 Option [] ["force-files"] (NoArg FlagForceFiles)
155 "ignore missing directories and libraries only",
156 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
157 "automatically build libs for GHCi (with register)",
158 Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance)
159 "allow registering multiple instances of the same package version",
160 Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
161 "expand environment variables (${name}-style) in input package descriptions",
162 Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
163 "expand ${pkgroot}-relative paths to absolute in output package descriptions",
164 Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
165 "preserve ${pkgroot}-relative paths in output package descriptions",
166 Option ['?'] ["help"] (NoArg FlagHelp)
167 "display this help and exit",
168 Option ['V'] ["version"] (NoArg FlagVersion)
169 "output version information and exit",
170 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
171 "print output in easy-to-parse format for some commands",
172 Option [] ["names-only"] (NoArg FlagNamesOnly)
173 "only print package names, not versions; can only be used with list --simple-output",
174 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
175 "ignore case for substring matching",
176 Option [] ["ipid"] (NoArg FlagIPId)
177 "interpret package arguments as installed package IDs",
178 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
179 "verbosity level (0-2, default 1)"
180 ]
181
182 data Verbosity = Silent | Normal | Verbose
183 deriving (Show, Eq, Ord)
184
185 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
186 getVerbosity v [] = Right v
187 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
188 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
189 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
190 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
191 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
192 getVerbosity v (_ : fs) = getVerbosity v fs
193
194 deprecFlags :: [OptDescr Flag]
195 deprecFlags = [
196 -- put deprecated flags here
197 ]
198
199 ourCopyright :: String
200 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
201
202 shortUsage :: String -> String
203 shortUsage prog = "For usage information see '" ++ prog ++ " --help'."
204
205 usageHeader :: String -> String
206 usageHeader prog = substProg prog $
207 "Usage:\n" ++
208 " $p init {path}\n" ++
209 " Create and initialise a package database at the location {path}.\n" ++
210 " Packages can be registered in the new database using the register\n" ++
211 " command with --package-db={path}. To use the new database with GHC,\n" ++
212 " use GHC's -package-db flag.\n" ++
213 "\n" ++
214 " $p register {filename | -}\n" ++
215 " Register the package using the specified installed package\n" ++
216 " description. The syntax for the latter is given in the $p\n" ++
217 " documentation. The input file should be encoded in UTF-8.\n" ++
218 "\n" ++
219 " $p update {filename | -}\n" ++
220 " Register the package, overwriting any other package with the\n" ++
221 " same name. The input file should be encoded in UTF-8.\n" ++
222 "\n" ++
223 " $p unregister {pkg-id}\n" ++
224 " Unregister the specified package.\n" ++
225 "\n" ++
226 " $p expose {pkg-id}\n" ++
227 " Expose the specified package.\n" ++
228 "\n" ++
229 " $p hide {pkg-id}\n" ++
230 " Hide the specified package.\n" ++
231 "\n" ++
232 " $p trust {pkg-id}\n" ++
233 " Trust the specified package.\n" ++
234 "\n" ++
235 " $p distrust {pkg-id}\n" ++
236 " Distrust the specified package.\n" ++
237 "\n" ++
238 " $p list [pkg]\n" ++
239 " List registered packages in the global database, and also the\n" ++
240 " user database if --user is given. If a package name is given\n" ++
241 " all the registered versions will be listed in ascending order.\n" ++
242 " Accepts the --simple-output flag.\n" ++
243 "\n" ++
244 " $p dot\n" ++
245 " Generate a graph of the package dependencies in a form suitable\n" ++
246 " for input for the graphviz tools. For example, to generate a PDF" ++
247 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
248 "\n" ++
249 " $p find-module {module}\n" ++
250 " List registered packages exposing module {module} in the global\n" ++
251 " database, and also the user database if --user is given.\n" ++
252 " All the registered versions will be listed in ascending order.\n" ++
253 " Accepts the --simple-output flag.\n" ++
254 "\n" ++
255 " $p latest {pkg-id}\n" ++
256 " Prints the highest registered version of a package.\n" ++
257 "\n" ++
258 " $p check\n" ++
259 " Check the consistency of package dependencies and list broken packages.\n" ++
260 " Accepts the --simple-output flag.\n" ++
261 "\n" ++
262 " $p describe {pkg}\n" ++
263 " Give the registered description for the specified package. The\n" ++
264 " description is returned in precisely the syntax required by $p\n" ++
265 " register.\n" ++
266 "\n" ++
267 " $p field {pkg} {field}\n" ++
268 " Extract the specified field of the package description for the\n" ++
269 " specified package. Accepts comma-separated multiple fields.\n" ++
270 "\n" ++
271 " $p dump\n" ++
272 " Dump the registered description for every package. This is like\n" ++
273 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
274 " by tools that parse the results, rather than humans. The output is\n" ++
275 " always encoded in UTF-8, regardless of the current locale.\n" ++
276 "\n" ++
277 " $p recache\n" ++
278 " Regenerate the package database cache. This command should only be\n" ++
279 " necessary if you added a package to the database by dropping a file\n" ++
280 " into the database directory manually. By default, the global DB\n" ++
281 " is recached; to recache a different DB use --user or --package-db\n" ++
282 " as appropriate.\n" ++
283 "\n" ++
284 " Substring matching is supported for {module} in find-module and\n" ++
285 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
286 " open substring ends (prefix*, *suffix, *infix*). Use --ipid to\n" ++
287 " match against the installed package ID instead.\n" ++
288 "\n" ++
289 " When asked to modify a database (register, unregister, update,\n"++
290 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
291 " default. Specifying --user causes it to act on the user database,\n"++
292 " or --package-db can be used to act on another database\n"++
293 " entirely. When multiple of these options are given, the rightmost\n"++
294 " one is used as the database to act upon.\n"++
295 "\n"++
296 " Commands that query the package database (list, tree, latest, describe,\n"++
297 " field) operate on the list of databases specified by the flags\n"++
298 " --user, --global, and --package-db. If none of these flags are\n"++
299 " given, the default is --global --user.\n"++
300 "\n" ++
301 " The following optional flags are also accepted:\n"
302
303 substProg :: String -> String -> String
304 substProg _ [] = []
305 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
306 substProg prog (c:xs) = c : substProg prog xs
307
308 -- -----------------------------------------------------------------------------
309 -- Do the business
310
311 data Force = NoForce | ForceFiles | ForceAll | CannotForce
312 deriving (Eq,Ord)
313
314 -- | Represents how a package may be specified by a user on the command line.
315 data PackageArg
316 -- | A package identifier foo-0.1; the version might be a glob.
317 = Id PackageIdentifier
318 -- | An installed package ID foo-0.1-HASH. This is guaranteed to uniquely
319 -- match a single entry in the package database.
320 | IPId InstalledPackageId
321 -- | A glob against the package name. The first string is the literal
322 -- glob, the second is a function which returns @True@ if the the argument
323 -- matches.
324 | Substring String (String->Bool)
325
326 runit :: Verbosity -> [Flag] -> [String] -> IO ()
327 runit verbosity cli nonopts = do
328 installSignalHandlers -- catch ^C and clean up
329 prog <- getProgramName
330 let
331 force
332 | FlagForce `elem` cli = ForceAll
333 | FlagForceFiles `elem` cli = ForceFiles
334 | otherwise = NoForce
335 as_ipid = FlagIPId `elem` cli
336 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
337 multi_instance = FlagMultiInstance `elem` cli
338 expand_env_vars= FlagExpandEnvVars `elem` cli
339 mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
340 where accumExpandPkgroot _ FlagExpandPkgroot = Just True
341 accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
342 accumExpandPkgroot x _ = x
343
344 splitFields fields = unfoldr splitComma (',':fields)
345 where splitComma "" = Nothing
346 splitComma fs = Just $ break (==',') (tail fs)
347
348 -- | Parses a glob into a predicate which tests if a string matches
349 -- the glob. Returns Nothing if the string in question is not a glob.
350 -- At the moment, we only support globs at the beginning and/or end of
351 -- strings. This function respects case sensitivity.
352 --
353 -- >>> fromJust (substringCheck "*") "anything"
354 -- True
355 --
356 -- >>> fromJust (substringCheck "string") "string"
357 -- True
358 --
359 -- >>> fromJust (substringCheck "*bar") "foobar"
360 -- True
361 --
362 -- >>> fromJust (substringCheck "foo*") "foobar"
363 -- True
364 --
365 -- >>> fromJust (substringCheck "*ooba*") "foobar"
366 -- True
367 --
368 -- >>> fromJust (substringCheck "f*bar") "foobar"
369 -- False
370 substringCheck :: String -> Maybe (String -> Bool)
371 substringCheck "" = Nothing
372 substringCheck "*" = Just (const True)
373 substringCheck [_] = Nothing
374 substringCheck (h:t) =
375 case (h, init t, last t) of
376 ('*',s,'*') -> Just (isInfixOf (f s) . f)
377 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
378 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
379 _ -> Nothing
380 where f | FlagIgnoreCase `elem` cli = map toLower
381 | otherwise = id
382 #if defined(GLOB)
383 glob x | System.Info.os=="mingw32" = do
384 -- glob echoes its argument, after win32 filename globbing
385 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
386 txt <- hGetContents o
387 return (read txt)
388 glob x | otherwise = return [x]
389 #endif
390 --
391 -- first, parse the command
392 case nonopts of
393 #if defined(GLOB)
394 -- dummy command to demonstrate usage and permit testing
395 -- without messing things up; use glob to selectively enable
396 -- windows filename globbing for file parameters
397 -- register, update, FlagGlobalConfig, FlagConfig; others?
398 ["glob", filename] -> do
399 print filename
400 glob filename >>= print
401 #endif
402 ["init", filename] ->
403 initPackageDB filename verbosity cli
404 ["register", filename] ->
405 registerPackage filename verbosity cli
406 auto_ghci_libs multi_instance
407 expand_env_vars False force
408 ["update", filename] ->
409 registerPackage filename verbosity cli
410 auto_ghci_libs multi_instance
411 expand_env_vars True force
412 ["unregister", pkgarg_str] -> do
413 pkgarg <- readPackageArg as_ipid pkgarg_str
414 unregisterPackage pkgarg verbosity cli force
415 ["expose", pkgarg_str] -> do
416 pkgarg <- readPackageArg as_ipid pkgarg_str
417 exposePackage pkgarg verbosity cli force
418 ["hide", pkgarg_str] -> do
419 pkgarg <- readPackageArg as_ipid pkgarg_str
420 hidePackage pkgarg verbosity cli force
421 ["trust", pkgarg_str] -> do
422 pkgarg <- readPackageArg as_ipid pkgarg_str
423 trustPackage pkgarg verbosity cli force
424 ["distrust", pkgarg_str] -> do
425 pkgarg <- readPackageArg as_ipid pkgarg_str
426 distrustPackage pkgarg verbosity cli force
427 ["list"] -> do
428 listPackages verbosity cli Nothing Nothing
429 ["list", pkgarg_str] ->
430 case substringCheck pkgarg_str of
431 Nothing -> do pkgarg <- readPackageArg as_ipid pkgarg_str
432 listPackages verbosity cli (Just pkgarg) Nothing
433 Just m -> listPackages verbosity cli
434 (Just (Substring pkgarg_str m)) Nothing
435 ["dot"] -> do
436 showPackageDot verbosity cli
437 ["find-module", moduleName] -> do
438 let match = maybe (==moduleName) id (substringCheck moduleName)
439 listPackages verbosity cli Nothing (Just match)
440 ["latest", pkgid_str] -> do
441 pkgid <- readGlobPkgId pkgid_str
442 latestPackage verbosity cli pkgid
443 ["describe", pkgid_str] -> do
444 pkgarg <- case substringCheck pkgid_str of
445 Nothing -> readPackageArg as_ipid pkgid_str
446 Just m -> return (Substring pkgid_str m)
447 describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
448
449 ["field", pkgid_str, fields] -> do
450 pkgarg <- case substringCheck pkgid_str of
451 Nothing -> readPackageArg as_ipid pkgid_str
452 Just m -> return (Substring pkgid_str m)
453 describeField verbosity cli pkgarg
454 (splitFields fields) (fromMaybe True mexpand_pkgroot)
455
456 ["check"] -> do
457 checkConsistency verbosity cli
458
459 ["dump"] -> do
460 dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
461
462 ["recache"] -> do
463 recache verbosity cli
464
465 [] -> do
466 die ("missing command\n" ++ shortUsage prog)
467 (_cmd:_) -> do
468 die ("command-line syntax error\n" ++ shortUsage prog)
469
470 parseCheck :: ReadP a a -> String -> String -> IO a
471 parseCheck parser str what =
472 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
473 [x] -> return x
474 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
475
476 readGlobPkgId :: String -> IO PackageIdentifier
477 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
478
479 parseGlobPackageId :: ReadP r PackageIdentifier
480 parseGlobPackageId =
481 parse
482 +++
483 (do n <- parse
484 _ <- string "-*"
485 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
486
487 readPackageArg :: Bool -> String -> IO PackageArg
488 readPackageArg True str =
489 parseCheck (IPId `fmap` parse) str "installed package id"
490 readPackageArg False str = Id `fmap` readGlobPkgId str
491
492 -- globVersion means "all versions"
493 globVersion :: Version
494 globVersion = Version{ versionBranch=[], versionTags=["*"] }
495
496 -- -----------------------------------------------------------------------------
497 -- Package databases
498
499 -- Some commands operate on a single database:
500 -- register, unregister, expose, hide, trust, distrust
501 -- however these commands also check the union of the available databases
502 -- in order to check consistency. For example, register will check that
503 -- dependencies exist before registering a package.
504 --
505 -- Some commands operate on multiple databases, with overlapping semantics:
506 -- list, describe, field
507
508 data PackageDB
509 = PackageDB {
510 location, locationAbsolute :: !FilePath,
511 -- We need both possibly-relative and definately-absolute package
512 -- db locations. This is because the relative location is used as
513 -- an identifier for the db, so it is important we do not modify it.
514 -- On the other hand we need the absolute path in a few places
515 -- particularly in relation to the ${pkgroot} stuff.
516
517 packages :: [InstalledPackageInfo]
518 }
519
520 type PackageDBStack = [PackageDB]
521 -- A stack of package databases. Convention: head is the topmost
522 -- in the stack.
523
524 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
525 allPackagesInStack = concatMap packages
526
527 getPkgDatabases :: Verbosity
528 -> Bool -- we are modifying, not reading
529 -> Bool -- use the user db
530 -> Bool -- read caches, if available
531 -> Bool -- expand vars, like ${pkgroot} and $topdir
532 -> [Flag]
533 -> IO (PackageDBStack,
534 -- the real package DB stack: [global,user] ++
535 -- DBs specified on the command line with -f.
536 Maybe FilePath,
537 -- which one to modify, if any
538 PackageDBStack)
539 -- the package DBs specified on the command
540 -- line, or [global,user] otherwise. This
541 -- is used as the list of package DBs for
542 -- commands that just read the DB, such as 'list'.
543
544 getPkgDatabases verbosity modify use_user use_cache expand_vars my_flags = do
545 -- first we determine the location of the global package config. On Windows,
546 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
547 -- location is passed to the binary using the --global-package-db flag by the
548 -- wrapper script.
549 let err_msg = "missing --global-package-db option, location of global package database unknown\n"
550 global_conf <-
551 case [ f | FlagGlobalConfig f <- my_flags ] of
552 [] -> do mb_dir <- getLibDir
553 case mb_dir of
554 Nothing -> die err_msg
555 Just dir -> do
556 r <- lookForPackageDBIn dir
557 case r of
558 Nothing -> die ("Can't find package database in " ++ dir)
559 Just path -> return path
560 fs -> return (last fs)
561
562 -- The value of the $topdir variable used in some package descriptions
563 -- Note that the way we calculate this is slightly different to how it
564 -- is done in ghc itself. We rely on the convention that the global
565 -- package db lives in ghc's libdir.
566 top_dir <- absolutePath (takeDirectory global_conf)
567
568 let no_user_db = FlagNoUserDb `elem` my_flags
569
570 -- get the location of the user package database, and create it if necessary
571 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
572 e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
573
574 mb_user_conf <-
575 case [ f | FlagUserConfig f <- my_flags ] of
576 _ | no_user_db -> return Nothing
577 [] -> case e_appdir of
578 Left _ -> return Nothing
579 Right appdir -> do
580 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
581 dir = appdir </> subdir
582 r <- lookForPackageDBIn dir
583 case r of
584 Nothing -> return (Just (dir </> "package.conf.d", False))
585 Just f -> return (Just (f, True))
586 fs -> return (Just (last fs, True))
587
588 -- If the user database exists, and for "check" and all "modify" commands
589 -- we will attempt to use the user db.
590 let sys_databases
591 | Just (user_conf,user_exists) <- mb_user_conf,
592 use_user || user_exists = [user_conf, global_conf]
593 | otherwise = [global_conf]
594
595 e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
596 let env_stack =
597 case e_pkg_path of
598 Left _ -> sys_databases
599 Right path
600 | last cs == "" -> init cs ++ sys_databases
601 | otherwise -> cs
602 where cs = parseSearchPath path
603
604 -- The "global" database is always the one at the bottom of the stack.
605 -- This is the database we modify by default.
606 virt_global_conf = last env_stack
607
608 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
609 where is_db_flag FlagUser
610 | Just (user_conf, _user_exists) <- mb_user_conf
611 = Just user_conf
612 is_db_flag FlagGlobal = Just virt_global_conf
613 is_db_flag (FlagConfig f) = Just f
614 is_db_flag _ = Nothing
615
616 let flag_db_names | null db_flags = env_stack
617 | otherwise = reverse (nub db_flags)
618
619 -- For a "modify" command, treat all the databases as
620 -- a stack, where we are modifying the top one, but it
621 -- can refer to packages in databases further down the
622 -- stack.
623
624 -- -f flags on the command line add to the database
625 -- stack, unless any of them are present in the stack
626 -- already.
627 let final_stack = filter (`notElem` env_stack)
628 [ f | FlagConfig f <- reverse my_flags ]
629 ++ env_stack
630
631 -- the database we actually modify is the one mentioned
632 -- rightmost on the command-line.
633 let to_modify
634 | not modify = Nothing
635 | null db_flags = Just virt_global_conf
636 | otherwise = Just (last db_flags)
637
638 db_stack <- sequence
639 [ do db <- readParseDatabase verbosity mb_user_conf modify use_cache db_path
640 if expand_vars then return (mungePackageDBPaths top_dir db)
641 else return db
642 | db_path <- final_stack ]
643
644 let flag_db_stack = [ db | db_name <- flag_db_names,
645 db <- db_stack, location db == db_name ]
646
647 when (verbosity > Normal) $ do
648 infoLn ("db stack: " ++ show (map location db_stack))
649 infoLn ("modifying: " ++ show to_modify)
650 infoLn ("flag db stack: " ++ show (map location flag_db_stack))
651
652 return (db_stack, to_modify, flag_db_stack)
653
654
655 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
656 lookForPackageDBIn dir = do
657 let path_dir = dir </> "package.conf.d"
658 exists_dir <- doesDirectoryExist path_dir
659 if exists_dir then return (Just path_dir) else do
660 let path_file = dir </> "package.conf"
661 exists_file <- doesFileExist path_file
662 if exists_file then return (Just path_file) else return Nothing
663
664 readParseDatabase :: Verbosity
665 -> Maybe (FilePath,Bool)
666 -> Bool -- we will be modifying, not just reading
667 -> Bool -- use cache
668 -> FilePath
669 -> IO PackageDB
670
671 readParseDatabase verbosity mb_user_conf modify use_cache path
672 -- the user database (only) is allowed to be non-existent
673 | Just (user_conf,False) <- mb_user_conf, path == user_conf
674 = mkPackageDB []
675 | otherwise
676 = do e <- tryIO $ getDirectoryContents path
677 case e of
678 Left err
679 | ioeGetErrorType err == InappropriateType ->
680 die ("ghc no longer supports single-file style package databases ("
681 ++ path ++ ") use 'ghc-pkg init' to create the database with "
682 ++ "the correct format.")
683 | otherwise -> ioError err
684 Right fs
685 | not use_cache -> ignore_cache (const $ return ())
686 | otherwise -> do
687 let cache = path </> cachefilename
688 tdir <- getModificationTime path
689 e_tcache <- tryIO $ getModificationTime cache
690 case e_tcache of
691 Left ex -> do
692 when (verbosity >= Normal && not modify || verbosity > Normal) $ do
693 if isDoesNotExistError ex
694 then do warn ("WARNING: cache does not exist: " ++ cache)
695 warn "ghc will fail to read this package db. Use 'ghc-pkg recache' to fix."
696 else do warn ("WARNING: cache cannot be read: " ++ show ex)
697 warn "ghc will fail to read this package db."
698 ignore_cache (const $ return ())
699 Right tcache -> do
700 let compareTimestampToCache file =
701 when (verbosity >= Verbose) $ do
702 tFile <- getModificationTime file
703 compareTimestampToCache' file tFile
704 compareTimestampToCache' file tFile = do
705 let rel = case tcache `compare` tFile of
706 LT -> " (NEWER than cache)"
707 GT -> " (older than cache)"
708 EQ -> " (same as cache)"
709 warn ("Timestamp " ++ show tFile
710 ++ " for " ++ file ++ rel)
711 when (verbosity >= Verbose) $ do
712 warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
713 compareTimestampToCache' path tdir
714 if tcache >= tdir
715 then do
716 when (verbosity > Normal) $
717 infoLn ("using cache: " ++ cache)
718 pkgs <- myReadBinPackageDB cache
719 mkPackageDB pkgs
720 else do
721 when (verbosity >= Normal && not modify || verbosity > Normal) $ do
722 warn ("WARNING: cache is out of date: "
723 ++ cache)
724 warn "ghc will see an old view of this package db. Use 'ghc-pkg recache' to fix."
725 ignore_cache compareTimestampToCache
726 where
727 ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
728 ignore_cache checkTime = do
729 let confs = filter (".conf" `isSuffixOf`) fs
730 doFile f = do checkTime f
731 parseSingletonPackageConf verbosity f
732 pkgs <- mapM doFile $ map (path </>) confs
733 mkPackageDB pkgs
734 where
735 mkPackageDB pkgs = do
736 path_abs <- absolutePath path
737 return PackageDB {
738 location = path,
739 locationAbsolute = path_abs,
740 packages = pkgs
741 }
742
743 -- read the package.cache file strictly, to work around a problem with
744 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
745 -- after it has been completely read, leading to a sharing violation
746 -- later.
747 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfo]
748 myReadBinPackageDB filepath = do
749 h <- openBinaryFile filepath ReadMode
750 sz <- hFileSize h
751 b <- B.hGet h (fromIntegral sz)
752 hClose h
753 return $ Bin.runGet Bin.get b
754
755 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
756 parseSingletonPackageConf verbosity file = do
757 when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
758 readUTF8File file >>= fmap fst . parsePackageInfo
759
760 cachefilename :: FilePath
761 cachefilename = "package.cache"
762
763 mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
764 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
765 db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
766 where
767 pkgroot = takeDirectory (locationAbsolute db)
768 -- It so happens that for both styles of package db ("package.conf"
769 -- files and "package.conf.d" dirs) the pkgroot is the parent directory
770 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
771
772 -- TODO: This code is duplicated in compiler/main/Packages.lhs
773 mungePackagePaths :: FilePath -> FilePath
774 -> InstalledPackageInfo -> InstalledPackageInfo
775 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
776 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
777 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
778 -- The "pkgroot" is the directory containing the package database.
779 --
780 -- Also perform a similar substitution for the older GHC-specific
781 -- "$topdir" variable. The "topdir" is the location of the ghc
782 -- installation (obtained from the -B option).
783 mungePackagePaths top_dir pkgroot pkg =
784 pkg {
785 importDirs = munge_paths (importDirs pkg),
786 includeDirs = munge_paths (includeDirs pkg),
787 libraryDirs = munge_paths (libraryDirs pkg),
788 frameworkDirs = munge_paths (frameworkDirs pkg),
789 haddockInterfaces = munge_paths (haddockInterfaces pkg),
790 -- haddock-html is allowed to be either a URL or a file
791 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
792 }
793 where
794 munge_paths = map munge_path
795 munge_urls = map munge_url
796
797 munge_path p
798 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
799 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
800 | otherwise = p
801
802 munge_url p
803 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
804 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
805 | otherwise = p
806
807 toUrlPath r p = "file:///"
808 -- URLs always use posix style '/' separators:
809 ++ FilePath.Posix.joinPath
810 (r : -- We need to drop a leading "/" or "\\"
811 -- if there is one:
812 dropWhile (all isPathSeparator)
813 (FilePath.splitDirectories p))
814
815 -- We could drop the separator here, and then use </> above. However,
816 -- by leaving it in and using ++ we keep the same path separator
817 -- rather than letting FilePath change it to use \ as the separator
818 stripVarPrefix var path = case stripPrefix var path of
819 Just [] -> Just []
820 Just cs@(c : _) | isPathSeparator c -> Just cs
821 _ -> Nothing
822
823
824 -- -----------------------------------------------------------------------------
825 -- Creating a new package DB
826
827 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
828 initPackageDB filename verbosity _flags = do
829 let eexist = die ("cannot create: " ++ filename ++ " already exists")
830 b1 <- doesFileExist filename
831 when b1 eexist
832 b2 <- doesDirectoryExist filename
833 when b2 eexist
834 filename_abs <- absolutePath filename
835 changeDB verbosity [] PackageDB {
836 location = filename, locationAbsolute = filename_abs,
837 packages = []
838 }
839
840 -- -----------------------------------------------------------------------------
841 -- Registering
842
843 registerPackage :: FilePath
844 -> Verbosity
845 -> [Flag]
846 -> Bool -- auto_ghci_libs
847 -> Bool -- multi_instance
848 -> Bool -- expand_env_vars
849 -> Bool -- update
850 -> Force
851 -> IO ()
852 registerPackage input verbosity my_flags auto_ghci_libs multi_instance
853 expand_env_vars update force = do
854 (db_stack, Just to_modify, _flag_dbs) <-
855 getPkgDatabases verbosity True{-modify-} True{-use user-} True{-use cache-}
856 False{-expand vars-} my_flags
857
858 let
859 db_to_operate_on = my_head "register" $
860 filter ((== to_modify).location) db_stack
861 --
862 when (auto_ghci_libs && verbosity >= Silent) $
863 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
864 --
865 s <-
866 case input of
867 "-" -> do
868 when (verbosity >= Normal) $
869 info "Reading package info from stdin ... "
870 -- fix the encoding to UTF-8, since this is an interchange format
871 hSetEncoding stdin utf8
872 getContents
873 f -> do
874 when (verbosity >= Normal) $
875 info ("Reading package info from " ++ show f ++ " ... ")
876 readUTF8File f
877
878 expanded <- if expand_env_vars then expandEnvVars s force
879 else return s
880
881 (pkg, ws) <- parsePackageInfo expanded
882 when (verbosity >= Normal) $
883 infoLn "done."
884
885 -- report any warnings from the parse phase
886 _ <- reportValidateErrors [] ws
887 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
888
889 -- validate the expanded pkg, but register the unexpanded
890 pkgroot <- absolutePath (takeDirectory to_modify)
891 let top_dir = takeDirectory (location (last db_stack))
892 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
893
894 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
895 -- truncate the stack for validation, because we don't allow
896 -- packages lower in the stack to refer to those higher up.
897 validatePackageConfig pkg_expanded verbosity truncated_stack
898 auto_ghci_libs multi_instance update force
899
900 -- postprocess the package
901 pkg' <- resolveReexports truncated_stack pkg
902
903 let
904 -- In the normal mode, we only allow one version of each package, so we
905 -- remove all instances with the same source package id as the one we're
906 -- adding. In the multi instance mode we don't do that, thus allowing
907 -- multiple instances with the same source package id.
908 removes = [ RemovePackage p
909 | not multi_instance,
910 p <- packages db_to_operate_on,
911 sourcePackageId p == sourcePackageId pkg ]
912 --
913 changeDB verbosity (removes ++ [AddPackage pkg']) db_to_operate_on
914
915 parsePackageInfo
916 :: String
917 -> IO (InstalledPackageInfo, [ValidateWarning])
918 parsePackageInfo str =
919 case parseInstalledPackageInfo str of
920 ParseOk warnings ok -> return (mungePackageInfo ok, ws)
921 where
922 ws = [ msg | PWarning msg <- warnings
923 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
924 ParseFailed err -> case locatedErrorMsg err of
925 (Nothing, s) -> die s
926 (Just l, s) -> die (show l ++ ": " ++ s)
927
928 mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo
929 mungePackageInfo ipi = ipi { packageKey = packageKey' }
930 where
931 packageKey'
932 | OldPackageKey (PackageIdentifier (PackageName "") _) <- packageKey ipi
933 = OldPackageKey (sourcePackageId ipi)
934 | otherwise = packageKey ipi
935
936 -- | Takes the "reexported-modules" field of an InstalledPackageInfo
937 -- and resolves the references so they point to the original exporter
938 -- of a module (i.e. the module is in exposed-modules, not
939 -- reexported-modules). This is done by maintaining an invariant on
940 -- the installed package database that a reexported-module field always
941 -- points to the original exporter.
942 resolveReexports :: PackageDBStack
943 -> InstalledPackageInfo
944 -> IO InstalledPackageInfo
945 resolveReexports db_stack pkg = do
946 let dep_mask = Set.fromList (depends pkg)
947 deps = filter (flip Set.member dep_mask . installedPackageId)
948 (allPackagesInStack db_stack)
949 matchExposed pkg_dep m = map ((,) (installedPackageId pkg_dep))
950 (filter (==m) (exposedModules pkg_dep))
951 worker ModuleExport{ exportOrigPackageName = Just pnm } pkg_dep
952 | pnm /= packageName (sourcePackageId pkg_dep) = []
953 -- Now, either the package matches, *or* we were asked to search the
954 -- true location ourselves.
955 worker ModuleExport{ exportOrigName = m } pkg_dep =
956 matchExposed pkg_dep m ++
957 map (fromMaybe (error $ "Impossible! Missing true location in " ++
958 display (installedPackageId pkg_dep))
959 . exportCachedTrueOrig)
960 (filter ((==m) . exportName) (reexportedModules pkg_dep))
961 self_reexports ModuleExport{ exportOrigPackageName = Just pnm }
962 | pnm /= packageName (sourcePackageId pkg) = []
963 self_reexports ModuleExport{ exportName = m', exportOrigName = m }
964 -- Self-reexport without renaming doesn't make sense
965 | m == m' = []
966 -- *Only* match against exposed modules!
967 | otherwise = matchExposed pkg m
968
969 r <- forM (reexportedModules pkg) $ \me -> do
970 case nub (concatMap (worker me) deps ++ self_reexports me) of
971 [c] -> return me { exportCachedTrueOrig = Just c }
972 [] -> die $ "Couldn't resolve reexport " ++ display me
973 cs -> die $ "Found multiple possible ways to resolve reexport " ++
974 display me ++ ": " ++ show cs
975 return (pkg { reexportedModules = r })
976
977 -- -----------------------------------------------------------------------------
978 -- Making changes to a package database
979
980 data DBOp = RemovePackage InstalledPackageInfo
981 | AddPackage InstalledPackageInfo
982 | ModifyPackage InstalledPackageInfo
983
984 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
985 changeDB verbosity cmds db = do
986 let db' = updateInternalDB db cmds
987 createDirectoryIfMissing True (location db)
988 changeDBDir verbosity cmds db'
989
990 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
991 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
992 where
993 do_cmd pkgs (RemovePackage p) =
994 filter ((/= installedPackageId p) . installedPackageId) pkgs
995 do_cmd pkgs (AddPackage p) = p : pkgs
996 do_cmd pkgs (ModifyPackage p) =
997 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
998
999
1000 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
1001 changeDBDir verbosity cmds db = do
1002 mapM_ do_cmd cmds
1003 updateDBCache verbosity db
1004 where
1005 do_cmd (RemovePackage p) = do
1006 let file = location db </> display (installedPackageId p) <.> "conf"
1007 when (verbosity > Normal) $ infoLn ("removing " ++ file)
1008 removeFileSafe file
1009 do_cmd (AddPackage p) = do
1010 let file = location db </> display (installedPackageId p) <.> "conf"
1011 when (verbosity > Normal) $ infoLn ("writing " ++ file)
1012 writeFileUtf8Atomic file (showInstalledPackageInfo p)
1013 do_cmd (ModifyPackage p) =
1014 do_cmd (AddPackage p)
1015
1016 updateDBCache :: Verbosity -> PackageDB -> IO ()
1017 updateDBCache verbosity db = do
1018 let filename = location db </> cachefilename
1019 when (verbosity > Normal) $
1020 infoLn ("writing cache " ++ filename)
1021 writeBinaryFileAtomic filename (packages db)
1022 `catchIO` \e ->
1023 if isPermissionError e
1024 then die (filename ++ ": you don't have permission to modify this file")
1025 else ioError e
1026 #ifndef mingw32_HOST_OS
1027 status <- getFileStatus filename
1028 setFileTimes (location db) (accessTime status) (modificationTime status)
1029 #endif
1030
1031 -- -----------------------------------------------------------------------------
1032 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
1033
1034 exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1035 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
1036
1037 hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1038 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
1039
1040 trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1041 trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
1042
1043 distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1044 distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
1045
1046 unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1047 unregisterPackage = modifyPackage RemovePackage
1048
1049 modifyPackage
1050 :: (InstalledPackageInfo -> DBOp)
1051 -> PackageArg
1052 -> Verbosity
1053 -> [Flag]
1054 -> Force
1055 -> IO ()
1056 modifyPackage fn pkgarg verbosity my_flags force = do
1057 (db_stack, Just _to_modify, flag_dbs) <-
1058 getPkgDatabases verbosity True{-modify-} True{-use user-} True{-use cache-}
1059 False{-expand vars-} my_flags
1060
1061 -- Do the search for the package respecting flags...
1062 (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg
1063 let
1064 db_name = location db
1065 pkgs = packages db
1066
1067 pks = map packageKey ps
1068
1069 cmds = [ fn pkg | pkg <- pkgs, packageKey pkg `elem` pks ]
1070 new_db = updateInternalDB db cmds
1071
1072 -- ...but do consistency checks with regards to the full stack
1073 old_broken = brokenPackages (allPackagesInStack db_stack)
1074 rest_of_stack = filter ((/= db_name) . location) db_stack
1075 new_stack = new_db : rest_of_stack
1076 new_broken = brokenPackages (allPackagesInStack new_stack)
1077 newly_broken = filter ((`notElem` map packageKey old_broken)
1078 . packageKey) new_broken
1079 --
1080 let displayQualPkgId pkg
1081 | [_] <- filter ((== pkgid) . sourcePackageId)
1082 (allPackagesInStack db_stack)
1083 = display pkgid
1084 | otherwise = display pkgid ++ "@" ++ display (packageKey pkg)
1085 where pkgid = sourcePackageId pkg
1086 when (not (null newly_broken)) $
1087 dieOrForceAll force ("unregistering would break the following packages: "
1088 ++ unwords (map displayQualPkgId newly_broken))
1089
1090 changeDB verbosity cmds db
1091
1092 recache :: Verbosity -> [Flag] -> IO ()
1093 recache verbosity my_flags = do
1094 (db_stack, Just to_modify, _flag_dbs) <-
1095 getPkgDatabases verbosity True{-modify-} True{-use user-} False{-no cache-}
1096 False{-expand vars-} my_flags
1097 let
1098 db_to_operate_on = my_head "recache" $
1099 filter ((== to_modify).location) db_stack
1100 --
1101 changeDB verbosity [] db_to_operate_on
1102
1103 -- -----------------------------------------------------------------------------
1104 -- Listing packages
1105
1106 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
1107 -> Maybe (String->Bool)
1108 -> IO ()
1109 listPackages verbosity my_flags mPackageName mModuleName = do
1110 let simple_output = FlagSimpleOutput `elem` my_flags
1111 (db_stack, _, flag_db_stack) <-
1112 getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-}
1113 False{-expand vars-} my_flags
1114
1115 let db_stack_filtered -- if a package is given, filter out all other packages
1116 | Just this <- mPackageName =
1117 [ db{ packages = filter (this `matchesPkg`) (packages db) }
1118 | db <- flag_db_stack ]
1119 | Just match <- mModuleName = -- packages which expose mModuleName
1120 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
1121 | db <- flag_db_stack ]
1122 | otherwise = flag_db_stack
1123
1124 db_stack_sorted
1125 = [ db{ packages = sort_pkgs (packages db) }
1126 | db <- db_stack_filtered ]
1127 where sort_pkgs = sortBy cmpPkgIds
1128 cmpPkgIds pkg1 pkg2 =
1129 case pkgName p1 `compare` pkgName p2 of
1130 LT -> LT
1131 GT -> GT
1132 EQ -> case pkgVersion p1 `compare` pkgVersion p2 of
1133 LT -> LT
1134 GT -> GT
1135 EQ -> packageKey pkg1 `compare` packageKey pkg2
1136 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
1137
1138 stack = reverse db_stack_sorted
1139
1140 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
1141
1142 pkg_map = allPackagesInStack db_stack
1143 broken = map packageKey (brokenPackages pkg_map)
1144
1145 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
1146 do hPutStrLn stdout (db_name ++ ":")
1147 if null pp_pkgs
1148 then hPutStrLn stdout " (no packages)"
1149 else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs)
1150 where
1151 -- Sort using instance Ord PackageId
1152 pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs
1153 pp_pkg p
1154 | packageKey p `elem` broken = printf "{%s}" doc
1155 | exposed p = doc
1156 | otherwise = printf "(%s)" doc
1157 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
1158 | otherwise = pkg
1159 where
1160 InstalledPackageId ipid = installedPackageId p
1161 pkg = display (sourcePackageId p)
1162
1163 show_simple = simplePackageList my_flags . allPackagesInStack
1164
1165 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
1166 prog <- getProgramName
1167 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
1168
1169 if simple_output then show_simple stack else do
1170
1171 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
1172 mapM_ show_normal stack
1173 #else
1174 let
1175 show_colour withF db =
1176 mconcat $ map (<#> termText "\n") $
1177 (termText (location db) :
1178 map (termText " " <#>) (map pp_pkg (packages db)))
1179 where
1180 pp_pkg p
1181 | packageKey p `elem` broken = withF Red doc
1182 | exposed p = doc
1183 | otherwise = withF Blue doc
1184 where doc | verbosity >= Verbose
1185 = termText (printf "%s (%s)" pkg ipid)
1186 | otherwise
1187 = termText pkg
1188 where
1189 InstalledPackageId ipid = installedPackageId p
1190 pkg = display (sourcePackageId p)
1191
1192 is_tty <- hIsTerminalDevice stdout
1193 if not is_tty
1194 then mapM_ show_normal stack
1195 else do tty <- Terminfo.setupTermFromEnv
1196 case Terminfo.getCapability tty withForegroundColor of
1197 Nothing -> mapM_ show_normal stack
1198 Just w -> runTermOutput tty $ mconcat $
1199 map (show_colour w) stack
1200 #endif
1201
1202 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1203 simplePackageList my_flags pkgs = do
1204 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1205 else display
1206 -- Sort using instance Ord PackageId
1207 strs = map showPkg $ sort $ map sourcePackageId pkgs
1208 when (not (null pkgs)) $
1209 hPutStrLn stdout $ concat $ intersperse " " strs
1210
1211 showPackageDot :: Verbosity -> [Flag] -> IO ()
1212 showPackageDot verbosity myflags = do
1213 (_, _, flag_db_stack) <-
1214 getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-}
1215 False{-expand vars-} myflags
1216
1217 let all_pkgs = allPackagesInStack flag_db_stack
1218 ipix = PackageIndex.fromList all_pkgs
1219
1220 putStrLn "digraph {"
1221 let quote s = '"':s ++ "\""
1222 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1223 | p <- all_pkgs,
1224 let from = display (sourcePackageId p),
1225 depid <- depends p,
1226 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1227 let to = display (sourcePackageId dep)
1228 ]
1229 putStrLn "}"
1230
1231 -- -----------------------------------------------------------------------------
1232 -- Prints the highest (hidden or exposed) version of a package
1233
1234 -- ToDo: This is no longer well-defined with package keys, because the
1235 -- dependencies may be varying versions
1236 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1237 latestPackage verbosity my_flags pkgid = do
1238 (_, _, flag_db_stack) <-
1239 getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-}
1240 False{-expand vars-} my_flags
1241
1242 ps <- findPackages flag_db_stack (Id pkgid)
1243 case ps of
1244 [] -> die "no matches"
1245 _ -> show_pkg . maximum . map sourcePackageId $ ps
1246 where
1247 show_pkg pid = hPutStrLn stdout (display pid)
1248
1249 -- -----------------------------------------------------------------------------
1250 -- Describe
1251
1252 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1253 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1254 (_, _, flag_db_stack) <-
1255 getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-}
1256 expand_pkgroot my_flags
1257 dbs <- findPackagesByDB flag_db_stack pkgarg
1258 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1259 | (db, pkgs) <- dbs, pkg <- pkgs ]
1260
1261 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1262 dumpPackages verbosity my_flags expand_pkgroot = do
1263 (_, _, flag_db_stack) <-
1264 getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-}
1265 expand_pkgroot my_flags
1266 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1267 | db <- flag_db_stack, pkg <- packages db ]
1268
1269 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1270 doDump expand_pkgroot pkgs = do
1271 -- fix the encoding to UTF-8, since this is an interchange format
1272 hSetEncoding stdout utf8
1273 putStrLn $
1274 intercalate "---\n"
1275 [ if expand_pkgroot
1276 then showInstalledPackageInfo pkg
1277 else showInstalledPackageInfo pkg ++ pkgrootField
1278 | (pkg, pkgloc) <- pkgs
1279 , let pkgroot = takeDirectory pkgloc
1280 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
1281
1282 -- PackageId is can have globVersion for the version
1283 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1284 findPackages db_stack pkgarg
1285 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1286
1287 findPackagesByDB :: PackageDBStack -> PackageArg
1288 -> IO [(PackageDB, [InstalledPackageInfo])]
1289 findPackagesByDB db_stack pkgarg
1290 = case [ (db, matched)
1291 | db <- db_stack,
1292 let matched = filter (pkgarg `matchesPkg`) (packages db),
1293 not (null matched) ] of
1294 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1295 ps -> return ps
1296 where
1297 pkg_msg (Id pkgid) = display pkgid
1298 pkg_msg (IPId ipid) = display ipid
1299 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1300
1301 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1302 pid `matches` pid'
1303 = (pkgName pid == pkgName pid')
1304 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1305
1306 realVersion :: PackageIdentifier -> Bool
1307 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1308 -- when versionBranch == [], this is a glob
1309
1310 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1311 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1312 (IPId ipid) `matchesPkg` pkg = ipid == installedPackageId pkg
1313 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1314
1315 -- -----------------------------------------------------------------------------
1316 -- Field
1317
1318 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1319 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1320 (_, _, flag_db_stack) <-
1321 getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-}
1322 expand_pkgroot my_flags
1323 fns <- mapM toField fields
1324 ps <- findPackages flag_db_stack pkgarg
1325 mapM_ (selectFields fns) ps
1326 where showFun = if FlagSimpleOutput `elem` my_flags
1327 then showSimpleInstalledPackageInfoField
1328 else showInstalledPackageInfoField
1329 toField f = case showFun f of
1330 Nothing -> die ("unknown field: " ++ f)
1331 Just fn -> return fn
1332 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
1333
1334
1335 -- -----------------------------------------------------------------------------
1336 -- Check: Check consistency of installed packages
1337
1338 checkConsistency :: Verbosity -> [Flag] -> IO ()
1339 checkConsistency verbosity my_flags = do
1340 (db_stack, _, _) <-
1341 getPkgDatabases verbosity False{-modify-} True{-use user-} True{-use cache-} True{-expand vars-} my_flags
1342 -- although check is not a modify command, we do need to use the user
1343 -- db, because ordering is important.
1344
1345 let simple_output = FlagSimpleOutput `elem` my_flags
1346
1347 let pkgs = allPackagesInStack db_stack
1348
1349 checkPackage p = do
1350 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
1351 False True True
1352 if null es
1353 then do when (not simple_output) $ do
1354 _ <- reportValidateErrors [] ws "" Nothing
1355 return ()
1356 return []
1357 else do
1358 when (not simple_output) $ do
1359 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1360 _ <- reportValidateErrors es ws " " Nothing
1361 return ()
1362 return [p]
1363
1364 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1365
1366 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1367 where not_in p = sourcePackageId p `notElem` all_ps
1368 all_ps = map sourcePackageId pkgs1
1369
1370 let not_broken_pkgs = filterOut broken_pkgs pkgs
1371 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1372 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1373
1374 when (not (null all_broken_pkgs)) $ do
1375 if simple_output
1376 then simplePackageList my_flags all_broken_pkgs
1377 else do
1378 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1379 "listed above, or because they depend on a broken package.")
1380 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1381
1382 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1383
1384
1385 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1386 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1387 closure pkgs db_stack = go pkgs db_stack
1388 where
1389 go avail not_avail =
1390 case partition (depsAvailable avail) not_avail of
1391 ([], not_avail') -> (avail, not_avail')
1392 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1393
1394 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1395 -> Bool
1396 depsAvailable pkgs_ok pkg = null dangling
1397 where dangling = filter (`notElem` pids) (depends pkg)
1398 pids = map installedPackageId pkgs_ok
1399
1400 -- we want mutually recursive groups of package to show up
1401 -- as broken. (#1750)
1402
1403 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1404 brokenPackages pkgs = snd (closure [] pkgs)
1405
1406 -----------------------------------------------------------------------------
1407 -- Sanity-check a new package config, and automatically build GHCi libs
1408 -- if requested.
1409
1410 type ValidateError = (Force,String)
1411 type ValidateWarning = String
1412
1413 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1414
1415 instance Functor Validate where
1416 fmap = liftM
1417
1418 instance Applicative Validate where
1419 pure = return
1420 (<*>) = ap
1421
1422 instance Monad Validate where
1423 return a = V $ return (a, [], [])
1424 m >>= k = V $ do
1425 (a, es, ws) <- runValidate m
1426 (b, es', ws') <- runValidate (k a)
1427 return (b,es++es',ws++ws')
1428
1429 verror :: Force -> String -> Validate ()
1430 verror f s = V (return ((),[(f,s)],[]))
1431
1432 vwarn :: String -> Validate ()
1433 vwarn s = V (return ((),[],["Warning: " ++ s]))
1434
1435 liftIO :: IO a -> Validate a
1436 liftIO k = V (k >>= \a -> return (a,[],[]))
1437
1438 -- returns False if we should die
1439 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1440 -> String -> Maybe Force -> IO Bool
1441 reportValidateErrors es ws prefix mb_force = do
1442 mapM_ (warn . (prefix++)) ws
1443 oks <- mapM report es
1444 return (and oks)
1445 where
1446 report (f,s)
1447 | Just force <- mb_force
1448 = if (force >= f)
1449 then do reportError (prefix ++ s ++ " (ignoring)")
1450 return True
1451 else if f < CannotForce
1452 then do reportError (prefix ++ s ++ " (use --force to override)")
1453 return False
1454 else do reportError err
1455 return False
1456 | otherwise = do reportError err
1457 return False
1458 where
1459 err = prefix ++ s
1460
1461 validatePackageConfig :: InstalledPackageInfo
1462 -> Verbosity
1463 -> PackageDBStack
1464 -> Bool -- auto-ghc-libs
1465 -> Bool -- multi_instance
1466 -> Bool -- update, or check
1467 -> Force
1468 -> IO ()
1469 validatePackageConfig pkg verbosity db_stack auto_ghci_libs
1470 multi_instance update force = do
1471 (_,es,ws) <- runValidate $
1472 checkPackageConfig pkg verbosity db_stack
1473 auto_ghci_libs multi_instance update
1474 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1475 when (not ok) $ exitWith (ExitFailure 1)
1476
1477 checkPackageConfig :: InstalledPackageInfo
1478 -> Verbosity
1479 -> PackageDBStack
1480 -> Bool -- auto-ghc-libs
1481 -> Bool -- multi_instance
1482 -> Bool -- update, or check
1483 -> Validate ()
1484 checkPackageConfig pkg verbosity db_stack auto_ghci_libs
1485 multi_instance update = do
1486 checkInstalledPackageId pkg db_stack update
1487 checkPackageId pkg
1488 checkPackageKey pkg
1489 checkDuplicates db_stack pkg multi_instance update
1490 mapM_ (checkDep db_stack) (depends pkg)
1491 checkDuplicateDepends (depends pkg)
1492 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1493 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1494 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1495 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1496 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1497 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1498 checkModules pkg
1499 mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1500 -- ToDo: check these somehow?
1501 -- extra_libraries :: [String],
1502 -- c_includes :: [String],
1503
1504 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1505 -> Validate ()
1506 checkInstalledPackageId ipi db_stack update = do
1507 let ipid@(InstalledPackageId str) = installedPackageId ipi
1508 when (null str) $ verror CannotForce "missing id field"
1509 let dups = [ p | p <- allPackagesInStack db_stack,
1510 installedPackageId p == ipid ]
1511 when (not update && not (null dups)) $
1512 verror CannotForce $
1513 "package(s) with this id already exist: " ++
1514 unwords (map (display.packageId) dups)
1515
1516 -- When the package name and version are put together, sometimes we can
1517 -- end up with a package id that cannot be parsed. This will lead to
1518 -- difficulties when the user wants to refer to the package later, so
1519 -- we check that the package id can be parsed properly here.
1520 checkPackageId :: InstalledPackageInfo -> Validate ()
1521 checkPackageId ipi =
1522 let str = display (sourcePackageId ipi) in
1523 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1524 [_] -> return ()
1525 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1526 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1527
1528 checkPackageKey :: InstalledPackageInfo -> Validate ()
1529 checkPackageKey ipi =
1530 let str = display (packageKey ipi) in
1531 case [ x :: PackageKey | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1532 [_] -> return ()
1533 [] -> verror CannotForce ("invalid package key: " ++ str)
1534 _ -> verror CannotForce ("ambiguous package key: " ++ str)
1535
1536 checkDuplicates :: PackageDBStack -> InstalledPackageInfo
1537 -> Bool -> Bool-> Validate ()
1538 checkDuplicates db_stack pkg multi_instance update = do
1539 let
1540 pkgid = sourcePackageId pkg
1541 pkgs = packages (head db_stack)
1542 --
1543 -- Check whether this package id already exists in this DB
1544 --
1545 when (not update && not multi_instance
1546 && (pkgid `elem` map sourcePackageId pkgs)) $
1547 verror CannotForce $
1548 "package " ++ display pkgid ++ " is already installed"
1549
1550 let
1551 uncasep = map toLower . display
1552 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1553
1554 when (not update && not (null dups)) $ verror ForceAll $
1555 "Package names may be treated case-insensitively in the future.\n"++
1556 "Package " ++ display pkgid ++
1557 " overlaps with: " ++ unwords (map display dups)
1558
1559 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1560 checkDir = checkPath False True
1561 checkFile = checkPath False False
1562 checkDirURL = checkPath True True
1563
1564 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1565 checkPath url_ok is_dir warn_only thisfield d
1566 | url_ok && ("http://" `isPrefixOf` d
1567 || "https://" `isPrefixOf` d) = return ()
1568
1569 | url_ok
1570 , Just d' <- stripPrefix "file://" d
1571 = checkPath False is_dir warn_only thisfield d'
1572
1573 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1574 -- variables having been expanded already, see mungePackagePaths.
1575
1576 | isRelative d = verror ForceFiles $
1577 thisfield ++ ": " ++ d ++ " is a relative path which "
1578 ++ "makes no sense (as there is nothing for it to be "
1579 ++ "relative to). You can make paths relative to the "
1580 ++ "package database itself by using ${pkgroot}."
1581 -- relative paths don't make any sense; #4134
1582 | otherwise = do
1583 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1584 when (not there) $
1585 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1586 ++ if is_dir then "directory" else "file"
1587 in
1588 if warn_only
1589 then vwarn msg
1590 else verror ForceFiles msg
1591
1592 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1593 checkDep db_stack pkgid
1594 | pkgid `elem` pkgids = return ()
1595 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1596 ++ "\" doesn't exist")
1597 where
1598 all_pkgs = allPackagesInStack db_stack
1599 pkgids = map installedPackageId all_pkgs
1600
1601 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1602 checkDuplicateDepends deps
1603 | null dups = return ()
1604 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1605 unwords (map display dups))
1606 where
1607 dups = [ p | (p:_:_) <- group (sort deps) ]
1608
1609 checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
1610 checkHSLib verbosity dirs auto_ghci_libs lib = do
1611 let batch_lib_file = "lib" ++ lib ++ ".a"
1612 filenames = ["lib" ++ lib ++ ".a",
1613 "lib" ++ lib ++ ".p_a",
1614 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so",
1615 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib",
1616 lib ++ "-ghc" ++ Version.version ++ ".dll"]
1617 m <- liftIO $ doesFileExistOnPath filenames dirs
1618 case m of
1619 Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++
1620 " on library path")
1621 Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
1622
1623 doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath)
1624 doesFileExistOnPath filenames paths = go fullFilenames
1625 where fullFilenames = [ (path, path </> filename)
1626 | filename <- filenames
1627 , path <- paths ]
1628 go [] = return Nothing
1629 go ((p, fp) : xs) = do b <- doesFileExist fp
1630 if b then return (Just p) else go xs
1631
1632 -- XXX maybe should check reexportedModules too
1633 checkModules :: InstalledPackageInfo -> Validate ()
1634 checkModules pkg = do
1635 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1636 where
1637 findModule modl =
1638 -- there's no interface file for GHC.Prim
1639 unless (modl == fromString "GHC.Prim") $ do
1640 let files = [ toFilePath modl <.> extension
1641 | extension <- ["hi", "p_hi", "dyn_hi" ] ]
1642 m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
1643 when (isNothing m) $
1644 verror ForceFiles ("cannot find any of " ++ show files)
1645
1646 checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
1647 checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
1648 | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
1649 | otherwise = return ()
1650 where
1651 ghci_lib_file = lib <.> "o"
1652
1653 -- automatically build the GHCi version of a batch lib,
1654 -- using ld --whole-archive.
1655
1656 autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
1657 autoBuildGHCiLib verbosity dir batch_file ghci_file = do
1658 let ghci_lib_file = dir ++ '/':ghci_file
1659 batch_lib_file = dir ++ '/':batch_file
1660 when (verbosity >= Normal) $
1661 info ("building GHCi library " ++ ghci_lib_file ++ "...")
1662 #if defined(darwin_HOST_OS)
1663 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1664 #elif defined(mingw32_HOST_OS)
1665 execDir <- getLibDir
1666 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1667 #else
1668 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1669 #endif
1670 when (r /= ExitSuccess) $ exitWith r
1671 when (verbosity >= Normal) $
1672 infoLn (" done.")
1673
1674 -- -----------------------------------------------------------------------------
1675 -- Searching for modules
1676
1677 #if not_yet
1678
1679 findModules :: [FilePath] -> IO [String]
1680 findModules paths =
1681 mms <- mapM searchDir paths
1682 return (concat mms)
1683
1684 searchDir path prefix = do
1685 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1686 searchEntries path prefix fs
1687
1688 searchEntries path prefix [] = return []
1689 searchEntries path prefix (f:fs)
1690 | looks_like_a_module = do
1691 ms <- searchEntries path prefix fs
1692 return (prefix `joinModule` f : ms)
1693 | looks_like_a_component = do
1694 ms <- searchDir (path </> f) (prefix `joinModule` f)
1695 ms' <- searchEntries path prefix fs
1696 return (ms ++ ms')
1697 | otherwise
1698 searchEntries path prefix fs
1699
1700 where
1701 (base,suffix) = splitFileExt f
1702 looks_like_a_module =
1703 suffix `elem` haskell_suffixes &&
1704 all okInModuleName base
1705 looks_like_a_component =
1706 null suffix && all okInModuleName base
1707
1708 okInModuleName c
1709
1710 #endif
1711
1712 -- ---------------------------------------------------------------------------
1713 -- expanding environment variables in the package configuration
1714
1715 expandEnvVars :: String -> Force -> IO String
1716 expandEnvVars str0 force = go str0 ""
1717 where
1718 go "" acc = return $! reverse acc
1719 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1720 = do value <- lookupEnvVar var
1721 go rest (reverse value ++ acc)
1722 where close c = c == '}' || c == '\n' -- don't span newlines
1723 go (c:str) acc
1724 = go str (c:acc)
1725
1726 lookupEnvVar :: String -> IO String
1727 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1728 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1729 lookupEnvVar nm =
1730 catchIO (System.Environment.getEnv nm)
1731 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1732 show nm)
1733 return "")
1734
1735 -----------------------------------------------------------------------------
1736
1737 getProgramName :: IO String
1738 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1739 where str `withoutSuffix` suff
1740 | suff `isSuffixOf` str = take (length str - length suff) str
1741 | otherwise = str
1742
1743 bye :: String -> IO a
1744 bye s = putStr s >> exitWith ExitSuccess
1745
1746 die :: String -> IO a
1747 die = dieWith 1
1748
1749 dieWith :: Int -> String -> IO a
1750 dieWith ec s = do
1751 prog <- getProgramName
1752 reportError (prog ++ ": " ++ s)
1753 exitWith (ExitFailure ec)
1754
1755 dieOrForceAll :: Force -> String -> IO ()
1756 dieOrForceAll ForceAll s = ignoreError s
1757 dieOrForceAll _other s = dieForcible s
1758
1759 warn :: String -> IO ()
1760 warn = reportError
1761
1762 -- send info messages to stdout
1763 infoLn :: String -> IO ()
1764 infoLn = putStrLn
1765
1766 info :: String -> IO ()
1767 info = putStr
1768
1769 ignoreError :: String -> IO ()
1770 ignoreError s = reportError (s ++ " (ignoring)")
1771
1772 reportError :: String -> IO ()
1773 reportError s = do hFlush stdout; hPutStrLn stderr s
1774
1775 dieForcible :: String -> IO ()
1776 dieForcible s = die (s ++ " (use --force to override)")
1777
1778 my_head :: String -> [a] -> a
1779 my_head s [] = error s
1780 my_head _ (x : _) = x
1781
1782 -----------------------------------------
1783 -- Cut and pasted from ghc/compiler/main/SysTools
1784
1785 #if defined(mingw32_HOST_OS)
1786 subst :: Char -> Char -> String -> String
1787 subst a b ls = map (\ x -> if x == a then b else x) ls
1788
1789 unDosifyPath :: FilePath -> FilePath
1790 unDosifyPath xs = subst '\\' '/' xs
1791
1792 getLibDir :: IO (Maybe String)
1793 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1794
1795 -- (getExecDir cmd) returns the directory in which the current
1796 -- executable, which should be called 'cmd', is running
1797 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1798 -- you'll get "/a/b/c" back as the result
1799 getExecDir :: String -> IO (Maybe String)
1800 getExecDir cmd =
1801 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1802 where initN n = reverse . drop n . reverse
1803 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1804
1805 getExecPath :: IO (Maybe String)
1806 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1807 where
1808 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1809 ret <- c_GetModuleFileName nullPtr buf size
1810 case ret of
1811 0 -> return Nothing
1812 _ | ret < size -> fmap Just $ peekCWString buf
1813 | otherwise -> try_size (size * 2)
1814
1815 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1816 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1817 #else
1818 getLibDir :: IO (Maybe String)
1819 getLibDir = return Nothing
1820 #endif
1821
1822 -----------------------------------------
1823 -- Adapted from ghc/compiler/utils/Panic
1824
1825 installSignalHandlers :: IO ()
1826 installSignalHandlers = do
1827 threadid <- myThreadId
1828 let
1829 interrupt = Exception.throwTo threadid
1830 (Exception.ErrorCall "interrupted")
1831 --
1832 #if !defined(mingw32_HOST_OS)
1833 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1834 _ <- installHandler sigINT (Catch interrupt) Nothing
1835 return ()
1836 #else
1837 -- GHC 6.3+ has support for console events on Windows
1838 -- NOTE: running GHCi under a bash shell for some reason requires
1839 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1840 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1841 -- why --SDM 17/12/2004
1842 let sig_handler ControlC = interrupt
1843 sig_handler Break = interrupt
1844 sig_handler _ = return ()
1845
1846 _ <- installHandler (Catch sig_handler)
1847 return ()
1848 #endif
1849
1850 #if mingw32_HOST_OS || mingw32_TARGET_OS
1851 throwIOIO :: Exception.IOException -> IO a
1852 throwIOIO = Exception.throwIO
1853 #endif
1854
1855 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1856 catchIO = Exception.catch
1857
1858 catchError :: IO a -> (String -> IO a) -> IO a
1859 catchError io handler = io `Exception.catch` handler'
1860 where handler' (Exception.ErrorCall err) = handler err
1861
1862 tryIO :: IO a -> IO (Either Exception.IOException a)
1863 tryIO = Exception.try
1864
1865 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1866 writeBinaryFileAtomic targetFile obj =
1867 withFileAtomic targetFile $ \h -> do
1868 hSetBinaryMode h True
1869 B.hPutStr h (Bin.encode obj)
1870
1871 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1872 writeFileUtf8Atomic targetFile content =
1873 withFileAtomic targetFile $ \h -> do
1874 hSetEncoding h utf8
1875 hPutStr h content
1876
1877 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1878 -- to use text files here, rather than binary files.
1879 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1880 withFileAtomic targetFile write_content = do
1881 (newFile, newHandle) <- openNewFile targetDir template
1882 do write_content newHandle
1883 hClose newHandle
1884 #if mingw32_HOST_OS || mingw32_TARGET_OS
1885 renameFile newFile targetFile
1886 -- If the targetFile exists then renameFile will fail
1887 `catchIO` \err -> do
1888 exists <- doesFileExist targetFile
1889 if exists
1890 then do removeFileSafe targetFile
1891 -- Big fat hairy race condition
1892 renameFile newFile targetFile
1893 -- If the removeFile succeeds and the renameFile fails
1894 -- then we've lost the atomic property.
1895 else throwIOIO err
1896 #else
1897 renameFile newFile targetFile
1898 #endif
1899 `Exception.onException` do hClose newHandle
1900 removeFileSafe newFile
1901 where
1902 template = targetName <.> "tmp"
1903 targetDir | null targetDir_ = "."
1904 | otherwise = targetDir_
1905 --TODO: remove this when takeDirectory/splitFileName is fixed
1906 -- to always return a valid dir
1907 (targetDir_,targetName) = splitFileName targetFile
1908
1909 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1910 openNewFile dir template = do
1911 -- this was added to System.IO in 6.12.1
1912 -- we must use this version because the version below opens the file
1913 -- in binary mode.
1914 openTempFileWithDefaultPermissions dir template
1915
1916 -- | The function splits the given string to substrings
1917 -- using 'isSearchPathSeparator'.
1918 parseSearchPath :: String -> [FilePath]
1919 parseSearchPath path = split path
1920 where
1921 split :: String -> [String]
1922 split s =
1923 case rest' of
1924 [] -> [chunk]
1925 _:rest -> chunk : split rest
1926 where
1927 chunk =
1928 case chunk' of
1929 #ifdef mingw32_HOST_OS
1930 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1931 #endif
1932 _ -> chunk'
1933
1934 (chunk', rest') = break isSearchPathSeparator s
1935
1936 readUTF8File :: FilePath -> IO String
1937 readUTF8File file = do
1938 h <- openFile file ReadMode
1939 -- fix the encoding to UTF-8
1940 hSetEncoding h utf8
1941 hGetContents h
1942
1943 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1944 removeFileSafe :: FilePath -> IO ()
1945 removeFileSafe fn =
1946 removeFile fn `catchIO` \ e ->
1947 when (not $ isDoesNotExistError e) $ ioError e
1948
1949 absolutePath :: FilePath -> IO FilePath
1950 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory