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