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