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