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