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