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