290993f4a505114e701ba60169f9582a7864eaa3
[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.abiHash = unAbiHash (abiHash pkg),
1111 GhcPkg.importDirs = importDirs pkg,
1112 GhcPkg.hsLibraries = hsLibraries pkg,
1113 GhcPkg.extraLibraries = extraLibraries pkg,
1114 GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg,
1115 GhcPkg.libraryDirs = libraryDirs pkg,
1116 GhcPkg.libraryDynDirs = libraryDynDirs pkg,
1117 GhcPkg.frameworks = frameworks pkg,
1118 GhcPkg.frameworkDirs = frameworkDirs pkg,
1119 GhcPkg.ldOptions = ldOptions pkg,
1120 GhcPkg.ccOptions = ccOptions pkg,
1121 GhcPkg.includes = includes pkg,
1122 GhcPkg.includeDirs = includeDirs pkg,
1123 GhcPkg.haddockInterfaces = haddockInterfaces pkg,
1124 GhcPkg.haddockHTMLs = haddockHTMLs pkg,
1125 GhcPkg.exposedModules = map convertExposed (exposedModules pkg),
1126 GhcPkg.hiddenModules = hiddenModules pkg,
1127 GhcPkg.indefinite = indefinite pkg,
1128 GhcPkg.exposed = exposed pkg,
1129 GhcPkg.trusted = trusted pkg
1130 }
1131 where convertExposed (ExposedModule n reexport) = (n, reexport)
1132
1133 instance GhcPkg.BinaryStringRep ComponentId where
1134 fromStringRep = mkComponentId . fromStringRep
1135 toStringRep = toStringRep . display
1136
1137 instance GhcPkg.BinaryStringRep PackageName where
1138 fromStringRep = mkPackageName . fromStringRep
1139 toStringRep = toStringRep . display
1140
1141 instance GhcPkg.BinaryStringRep PackageIdentifier where
1142 fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier")
1143 . simpleParse . fromStringRep
1144 toStringRep = toStringRep . display
1145
1146 instance GhcPkg.BinaryStringRep ModuleName where
1147 fromStringRep = ModuleName.fromString . fromStringRep
1148 toStringRep = toStringRep . display
1149
1150 instance GhcPkg.BinaryStringRep String where
1151 fromStringRep = fromUTF8 . BS.unpack
1152 toStringRep = BS.pack . toUTF8
1153
1154 instance GhcPkg.BinaryStringRep UnitId where
1155 fromStringRep = mkUnitId . fromStringRep
1156 toStringRep = toStringRep . display
1157
1158 instance GhcPkg.DbUnitIdModuleRep UnitId ComponentId OpenUnitId ModuleName OpenModule where
1159 fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name
1160 fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name
1161 toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name
1162 toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name
1163 fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts)
1164 fromDbUnitId (GhcPkg.DbInstalledUnitId uid)
1165 = DefiniteUnitId (unsafeMkDefUnitId uid)
1166 toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts)
1167 toDbUnitId (DefiniteUnitId def_uid)
1168 = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid)
1169
1170 -- -----------------------------------------------------------------------------
1171 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
1172
1173 exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1174 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
1175
1176 hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1177 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
1178
1179 trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1180 trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
1181
1182 distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1183 distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
1184
1185 unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1186 unregisterPackage = modifyPackage RemovePackage
1187
1188 modifyPackage
1189 :: (InstalledPackageInfo -> DBOp)
1190 -> PackageArg
1191 -> Verbosity
1192 -> [Flag]
1193 -> Force
1194 -> IO ()
1195 modifyPackage fn pkgarg verbosity my_flags force = do
1196 (db_stack, Just _to_modify, flag_dbs) <-
1197 getPkgDatabases verbosity True{-modify-} True{-use user-}
1198 True{-use cache-} False{-expand vars-} my_flags
1199
1200 -- Do the search for the package respecting flags...
1201 (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg
1202 let
1203 db_name = location db
1204 pkgs = packages db
1205
1206 pks = map installedUnitId ps
1207
1208 cmds = [ fn pkg | pkg <- pkgs, installedUnitId pkg `elem` pks ]
1209 new_db = updateInternalDB db cmds
1210
1211 -- ...but do consistency checks with regards to the full stack
1212 old_broken = brokenPackages (allPackagesInStack db_stack)
1213 rest_of_stack = filter ((/= db_name) . location) db_stack
1214 new_stack = new_db : rest_of_stack
1215 new_broken = brokenPackages (allPackagesInStack new_stack)
1216 newly_broken = filter ((`notElem` map installedUnitId old_broken)
1217 . installedUnitId) new_broken
1218 --
1219 let displayQualPkgId pkg
1220 | [_] <- filter ((== pkgid) . sourcePackageId)
1221 (allPackagesInStack db_stack)
1222 = display pkgid
1223 | otherwise = display pkgid ++ "@" ++ display (installedUnitId pkg)
1224 where pkgid = sourcePackageId pkg
1225 when (not (null newly_broken)) $
1226 dieOrForceAll force ("unregistering would break the following packages: "
1227 ++ unwords (map displayQualPkgId newly_broken))
1228
1229 changeDB verbosity cmds db
1230
1231 recache :: Verbosity -> [Flag] -> IO ()
1232 recache verbosity my_flags = do
1233 (db_stack, Just to_modify, _flag_dbs) <-
1234 getPkgDatabases verbosity True{-modify-} True{-use user-} False{-no cache-}
1235 False{-expand vars-} my_flags
1236 let
1237 db_to_operate_on = my_head "recache" $
1238 filter ((== to_modify).location) db_stack
1239 --
1240 changeDB verbosity [] db_to_operate_on
1241
1242 -- -----------------------------------------------------------------------------
1243 -- Listing packages
1244
1245 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
1246 -> Maybe (String->Bool)
1247 -> IO ()
1248 listPackages verbosity my_flags mPackageName mModuleName = do
1249 let simple_output = FlagSimpleOutput `elem` my_flags
1250 (db_stack, _, flag_db_stack) <-
1251 getPkgDatabases verbosity False{-modify-} False{-use user-}
1252 True{-use cache-} False{-expand vars-} my_flags
1253
1254 let db_stack_filtered -- if a package is given, filter out all other packages
1255 | Just this <- mPackageName =
1256 [ db{ packages = filter (this `matchesPkg`) (packages db) }
1257 | db <- flag_db_stack ]
1258 | Just match <- mModuleName = -- packages which expose mModuleName
1259 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
1260 | db <- flag_db_stack ]
1261 | otherwise = flag_db_stack
1262
1263 db_stack_sorted
1264 = [ db{ packages = sort_pkgs (packages db) }
1265 | db <- db_stack_filtered ]
1266 where sort_pkgs = sortBy cmpPkgIds
1267 cmpPkgIds pkg1 pkg2 =
1268 case pkgName p1 `compare` pkgName p2 of
1269 LT -> LT
1270 GT -> GT
1271 EQ -> case pkgVersion p1 `compare` pkgVersion p2 of
1272 LT -> LT
1273 GT -> GT
1274 EQ -> installedUnitId pkg1 `compare` installedUnitId pkg2
1275 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
1276
1277 stack = reverse db_stack_sorted
1278
1279 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
1280
1281 pkg_map = allPackagesInStack db_stack
1282 broken = map installedUnitId (brokenPackages pkg_map)
1283
1284 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
1285 do hPutStrLn stdout db_name
1286 if null pkg_confs
1287 then hPutStrLn stdout " (no packages)"
1288 else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs))
1289 where
1290 pp_pkg p
1291 | installedUnitId p `elem` broken = printf "{%s}" doc
1292 | exposed p = doc
1293 | otherwise = printf "(%s)" doc
1294 where doc | verbosity >= Verbose = printf "%s (%s)" pkg (display (installedUnitId p))
1295 | otherwise = pkg
1296 where
1297 pkg = display (sourcePackageId p)
1298
1299 show_simple = simplePackageList my_flags . allPackagesInStack
1300
1301 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
1302 prog <- getProgramName
1303 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
1304
1305 if simple_output then show_simple stack else do
1306
1307 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
1308 mapM_ show_normal stack
1309 #else
1310 let
1311 show_colour withF db@PackageDB{ packages = pkg_confs } =
1312 if null pkg_confs
1313 then termText (location db) <#> termText "\n (no packages)\n"
1314 else
1315 mconcat $ map (<#> termText "\n") $
1316 (termText (location db)
1317 : map (termText " " <#>) (map pp_pkg pkg_confs))
1318 where
1319 pp_pkg p
1320 | installedUnitId p `elem` broken = withF Red doc
1321 | exposed p = doc
1322 | otherwise = withF Blue doc
1323 where doc | verbosity >= Verbose
1324 = termText (printf "%s (%s)" pkg (display (installedUnitId p)))
1325 | otherwise
1326 = termText pkg
1327 where
1328 pkg = display (sourcePackageId p)
1329
1330 is_tty <- hIsTerminalDevice stdout
1331 if not is_tty
1332 then mapM_ show_normal stack
1333 else do tty <- Terminfo.setupTermFromEnv
1334 case Terminfo.getCapability tty withForegroundColor of
1335 Nothing -> mapM_ show_normal stack
1336 Just w -> runTermOutput tty $ mconcat $
1337 map (show_colour w) stack
1338 #endif
1339
1340 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1341 simplePackageList my_flags pkgs = do
1342 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1343 else display
1344 strs = map showPkg $ map sourcePackageId pkgs
1345 when (not (null pkgs)) $
1346 hPutStrLn stdout $ concat $ intersperse " " strs
1347
1348 showPackageDot :: Verbosity -> [Flag] -> IO ()
1349 showPackageDot verbosity myflags = do
1350 (_, _, flag_db_stack) <-
1351 getPkgDatabases verbosity False{-modify-} False{-use user-}
1352 True{-use cache-} False{-expand vars-} myflags
1353
1354 let all_pkgs = allPackagesInStack flag_db_stack
1355 ipix = PackageIndex.fromList all_pkgs
1356
1357 putStrLn "digraph {"
1358 let quote s = '"':s ++ "\""
1359 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1360 | p <- all_pkgs,
1361 let from = display (sourcePackageId p),
1362 key <- depends p,
1363 Just dep <- [PackageIndex.lookupUnitId ipix key],
1364 let to = display (sourcePackageId dep)
1365 ]
1366 putStrLn "}"
1367
1368 -- -----------------------------------------------------------------------------
1369 -- Prints the highest (hidden or exposed) version of a package
1370
1371 -- ToDo: This is no longer well-defined with unit ids, because the
1372 -- dependencies may be varying versions
1373 latestPackage :: Verbosity -> [Flag] -> GlobPackageIdentifier -> IO ()
1374 latestPackage verbosity my_flags pkgid = do
1375 (_, _, flag_db_stack) <-
1376 getPkgDatabases verbosity False{-modify-} False{-use user-}
1377 True{-use cache-} False{-expand vars-} my_flags
1378
1379 ps <- findPackages flag_db_stack (Id pkgid)
1380 case ps of
1381 [] -> die "no matches"
1382 _ -> show_pkg . maximum . map sourcePackageId $ ps
1383 where
1384 show_pkg pid = hPutStrLn stdout (display pid)
1385
1386 -- -----------------------------------------------------------------------------
1387 -- Describe
1388
1389 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1390 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1391 (_, _, flag_db_stack) <-
1392 getPkgDatabases verbosity False{-modify-} False{-use user-}
1393 True{-use cache-} expand_pkgroot my_flags
1394 dbs <- findPackagesByDB flag_db_stack pkgarg
1395 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1396 | (db, pkgs) <- dbs, pkg <- pkgs ]
1397
1398 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1399 dumpPackages verbosity my_flags expand_pkgroot = do
1400 (_, _, flag_db_stack) <-
1401 getPkgDatabases verbosity False{-modify-} False{-use user-}
1402 True{-use cache-} expand_pkgroot my_flags
1403 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1404 | db <- flag_db_stack, pkg <- packages db ]
1405
1406 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1407 doDump expand_pkgroot pkgs = do
1408 -- fix the encoding to UTF-8, since this is an interchange format
1409 hSetEncoding stdout utf8
1410 putStrLn $
1411 intercalate "---\n"
1412 [ if expand_pkgroot
1413 then showInstalledPackageInfo pkg
1414 else showInstalledPackageInfo pkg ++ pkgrootField
1415 | (pkg, pkgloc) <- pkgs
1416 , let pkgroot = takeDirectory pkgloc
1417 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
1418
1419 -- PackageId is can have globVersion for the version
1420 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1421 findPackages db_stack pkgarg
1422 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1423
1424 findPackagesByDB :: PackageDBStack -> PackageArg
1425 -> IO [(PackageDB, [InstalledPackageInfo])]
1426 findPackagesByDB db_stack pkgarg
1427 = case [ (db, matched)
1428 | db <- db_stack,
1429 let matched = filter (pkgarg `matchesPkg`) (packages db),
1430 not (null matched) ] of
1431 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1432 ps -> return ps
1433 where
1434 pkg_msg (Id pkgid) = displayGlobPkgId pkgid
1435 pkg_msg (IUId ipid) = display ipid
1436 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1437
1438 matches :: GlobPackageIdentifier -> PackageIdentifier -> Bool
1439 GlobPackageIdentifier pn `matches` pid'
1440 = (pn == pkgName pid')
1441 ExactPackageIdentifier pid `matches` pid'
1442 = pkgName pid == pkgName pid' &&
1443 (pkgVersion pid == pkgVersion pid' || pkgVersion pid == nullVersion)
1444
1445 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1446 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1447 (IUId ipid) `matchesPkg` pkg = ipid == installedUnitId pkg
1448 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1449
1450 -- -----------------------------------------------------------------------------
1451 -- Field
1452
1453 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1454 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1455 (_, _, flag_db_stack) <-
1456 getPkgDatabases verbosity False{-modify-} False{-use user-}
1457 True{-use cache-} expand_pkgroot my_flags
1458 fns <- mapM toField fields
1459 ps <- findPackages flag_db_stack pkgarg
1460 mapM_ (selectFields fns) ps
1461 where showFun = if FlagSimpleOutput `elem` my_flags
1462 then showSimpleInstalledPackageInfoField
1463 else showInstalledPackageInfoField
1464 toField f = case showFun f of
1465 Nothing -> die ("unknown field: " ++ f)
1466 Just fn -> return fn
1467 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
1468
1469
1470 -- -----------------------------------------------------------------------------
1471 -- Check: Check consistency of installed packages
1472
1473 checkConsistency :: Verbosity -> [Flag] -> IO ()
1474 checkConsistency verbosity my_flags = do
1475 (db_stack, _, _) <-
1476 getPkgDatabases verbosity False{-modify-} True{-use user-}
1477 True{-use cache-} True{-expand vars-}
1478 my_flags
1479 -- although check is not a modify command, we do need to use the user
1480 -- db, because we may need it to verify package deps.
1481
1482 let simple_output = FlagSimpleOutput `elem` my_flags
1483
1484 let pkgs = allPackagesInStack db_stack
1485
1486 checkPackage p = do
1487 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
1488 True True
1489 if null es
1490 then do when (not simple_output) $ do
1491 _ <- reportValidateErrors verbosity [] ws "" Nothing
1492 return ()
1493 return []
1494 else do
1495 when (not simple_output) $ do
1496 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1497 _ <- reportValidateErrors verbosity es ws " " Nothing
1498 return ()
1499 return [p]
1500
1501 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1502
1503 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1504 where not_in p = sourcePackageId p `notElem` all_ps
1505 all_ps = map sourcePackageId pkgs1
1506
1507 let not_broken_pkgs = filterOut broken_pkgs pkgs
1508 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1509 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1510
1511 when (not (null all_broken_pkgs)) $ do
1512 if simple_output
1513 then simplePackageList my_flags all_broken_pkgs
1514 else do
1515 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1516 "listed above, or because they depend on a broken package.")
1517 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1518
1519 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1520
1521
1522 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1523 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1524 closure pkgs db_stack = go pkgs db_stack
1525 where
1526 go avail not_avail =
1527 case partition (depsAvailable avail) not_avail of
1528 ([], not_avail') -> (avail, not_avail')
1529 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1530
1531 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1532 -> Bool
1533 depsAvailable pkgs_ok pkg = null dangling
1534 where dangling = filter (`notElem` pids) (depends pkg)
1535 pids = map installedUnitId pkgs_ok
1536
1537 -- we want mutually recursive groups of package to show up
1538 -- as broken. (#1750)
1539
1540 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1541 brokenPackages pkgs = snd (closure [] pkgs)
1542
1543 -----------------------------------------------------------------------------
1544 -- Sanity-check a new package config, and automatically build GHCi libs
1545 -- if requested.
1546
1547 type ValidateError = (Force,String)
1548 type ValidateWarning = String
1549
1550 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1551
1552 instance Functor Validate where
1553 fmap = liftM
1554
1555 instance Applicative Validate where
1556 pure a = V $ pure (a, [], [])
1557 (<*>) = ap
1558
1559 instance Monad Validate where
1560 m >>= k = V $ do
1561 (a, es, ws) <- runValidate m
1562 (b, es', ws') <- runValidate (k a)
1563 return (b,es++es',ws++ws')
1564
1565 verror :: Force -> String -> Validate ()
1566 verror f s = V (return ((),[(f,s)],[]))
1567
1568 vwarn :: String -> Validate ()
1569 vwarn s = V (return ((),[],["Warning: " ++ s]))
1570
1571 liftIO :: IO a -> Validate a
1572 liftIO k = V (k >>= \a -> return (a,[],[]))
1573
1574 -- returns False if we should die
1575 reportValidateErrors :: Verbosity -> [ValidateError] -> [ValidateWarning]
1576 -> String -> Maybe Force -> IO Bool
1577 reportValidateErrors verbosity es ws prefix mb_force = do
1578 mapM_ (warn . (prefix++)) ws
1579 oks <- mapM report es
1580 return (and oks)
1581 where
1582 report (f,s)
1583 | Just force <- mb_force
1584 = if (force >= f)
1585 then do when (verbosity >= Normal) $
1586 reportError (prefix ++ s ++ " (ignoring)")
1587 return True
1588 else if f < CannotForce
1589 then do reportError (prefix ++ s ++ " (use --force to override)")
1590 return False
1591 else do reportError err
1592 return False
1593 | otherwise = do reportError err
1594 return False
1595 where
1596 err = prefix ++ s
1597
1598 validatePackageConfig :: InstalledPackageInfo
1599 -> Verbosity
1600 -> PackageDBStack
1601 -> Bool -- multi_instance
1602 -> Bool -- update, or check
1603 -> Force
1604 -> IO ()
1605 validatePackageConfig pkg verbosity db_stack
1606 multi_instance update force = do
1607 (_,es,ws) <- runValidate $
1608 checkPackageConfig pkg verbosity db_stack
1609 multi_instance update
1610 ok <- reportValidateErrors verbosity es ws
1611 (display (sourcePackageId pkg) ++ ": ") (Just force)
1612 when (not ok) $ exitWith (ExitFailure 1)
1613
1614 checkPackageConfig :: InstalledPackageInfo
1615 -> Verbosity
1616 -> PackageDBStack
1617 -> Bool -- multi_instance
1618 -> Bool -- update, or check
1619 -> Validate ()
1620 checkPackageConfig pkg verbosity db_stack
1621 multi_instance update = do
1622 checkPackageId pkg
1623 checkUnitId pkg db_stack update
1624 checkDuplicates db_stack pkg multi_instance update
1625 mapM_ (checkDep db_stack) (depends pkg)
1626 checkDuplicateDepends (depends pkg)
1627 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1628 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1629 mapM_ (checkDir True "dynamic-library-dirs") (libraryDynDirs pkg)
1630 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1631 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1632 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1633 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1634 checkDuplicateModules pkg
1635 checkExposedModules db_stack pkg
1636 checkOtherModules pkg
1637 let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg)))
1638 when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg)
1639 -- ToDo: check these somehow?
1640 -- extra_libraries :: [String],
1641 -- c_includes :: [String],
1642
1643 -- When the package name and version are put together, sometimes we can
1644 -- end up with a package id that cannot be parsed. This will lead to
1645 -- difficulties when the user wants to refer to the package later, so
1646 -- we check that the package id can be parsed properly here.
1647 checkPackageId :: InstalledPackageInfo -> Validate ()
1648 checkPackageId ipi =
1649 let str = display (sourcePackageId ipi) in
1650 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1651 [_] -> return ()
1652 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1653 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1654
1655 checkUnitId :: InstalledPackageInfo -> PackageDBStack -> Bool
1656 -> Validate ()
1657 checkUnitId ipi db_stack update = do
1658 let uid = installedUnitId ipi
1659 when (null (display uid)) $ verror CannotForce "missing id field"
1660 when (display uid /= compatPackageKey ipi) $
1661 verror CannotForce $ "installed package info from too old version of Cabal "
1662 ++ "(key field does not match id field)"
1663 let dups = [ p | p <- allPackagesInStack db_stack,
1664 installedUnitId p == uid ]
1665 when (not update && not (null dups)) $
1666 verror CannotForce $
1667 "package(s) with this id already exist: " ++
1668 unwords (map (display.installedUnitId) dups)
1669
1670 checkDuplicates :: PackageDBStack -> InstalledPackageInfo
1671 -> Bool -> Bool-> Validate ()
1672 checkDuplicates db_stack pkg multi_instance update = do
1673 let
1674 pkgid = sourcePackageId pkg
1675 pkgs = packages (head db_stack)
1676 --
1677 -- Check whether this package id already exists in this DB
1678 --
1679 when (not update && not multi_instance
1680 && (pkgid `elem` map sourcePackageId pkgs)) $
1681 verror CannotForce $
1682 "package " ++ display pkgid ++ " is already installed"
1683
1684 let
1685 uncasep = map toLower . display
1686 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1687
1688 when (not update && not multi_instance
1689 && not (null dups)) $ verror ForceAll $
1690 "Package names may be treated case-insensitively in the future.\n"++
1691 "Package " ++ display pkgid ++
1692 " overlaps with: " ++ unwords (map display dups)
1693
1694 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1695 checkDir = checkPath False True
1696 checkFile = checkPath False False
1697 checkDirURL = checkPath True True
1698
1699 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1700 checkPath url_ok is_dir warn_only thisfield d
1701 | url_ok && ("http://" `isPrefixOf` d
1702 || "https://" `isPrefixOf` d) = return ()
1703
1704 | url_ok
1705 , Just d' <- stripPrefix "file://" d
1706 = checkPath False is_dir warn_only thisfield d'
1707
1708 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1709 -- variables having been expanded already, see mungePackagePaths.
1710
1711 | isRelative d = verror ForceFiles $
1712 thisfield ++ ": " ++ d ++ " is a relative path which "
1713 ++ "makes no sense (as there is nothing for it to be "
1714 ++ "relative to). You can make paths relative to the "
1715 ++ "package database itself by using ${pkgroot}."
1716 -- relative paths don't make any sense; #4134
1717 | otherwise = do
1718 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1719 when (not there) $
1720 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1721 ++ if is_dir then "directory" else "file"
1722 in
1723 if warn_only
1724 then vwarn msg
1725 else verror ForceFiles msg
1726
1727 checkDep :: PackageDBStack -> UnitId -> Validate ()
1728 checkDep db_stack pkgid
1729 | pkgid `elem` pkgids = return ()
1730 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1731 ++ "\" doesn't exist")
1732 where
1733 all_pkgs = allPackagesInStack db_stack
1734 pkgids = map installedUnitId all_pkgs
1735
1736 checkDuplicateDepends :: [UnitId] -> Validate ()
1737 checkDuplicateDepends deps
1738 | null dups = return ()
1739 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1740 unwords (map display dups))
1741 where
1742 dups = [ p | (p:_:_) <- group (sort deps) ]
1743
1744 checkHSLib :: Verbosity -> [String] -> String -> Validate ()
1745 checkHSLib _verbosity dirs lib = do
1746 let filenames = ["lib" ++ lib ++ ".a",
1747 "lib" ++ lib ++ ".p_a",
1748 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so",
1749 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib",
1750 lib ++ "-ghc" ++ Version.version ++ ".dll"]
1751 b <- liftIO $ doesFileExistOnPath filenames dirs
1752 when (not b) $
1753 verror ForceFiles ("cannot find any of " ++ show filenames ++
1754 " on library path")
1755
1756 doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool
1757 doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames
1758 where fullFilenames = [ path </> filename
1759 | filename <- filenames
1760 , path <- paths ]
1761
1762 -- | Perform validation checks (module file existence checks) on the
1763 -- @hidden-modules@ field.
1764 checkOtherModules :: InstalledPackageInfo -> Validate ()
1765 checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg)
1766
1767 -- | Perform validation checks (module file existence checks and module
1768 -- reexport checks) on the @exposed-modules@ field.
1769 checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate ()
1770 checkExposedModules db_stack pkg =
1771 mapM_ checkExposedModule (exposedModules pkg)
1772 where
1773 checkExposedModule (ExposedModule modl reexport) = do
1774 let checkOriginal = checkModuleFile pkg modl
1775 checkReexport = checkModule "module reexport" db_stack pkg
1776 maybe checkOriginal checkReexport reexport
1777
1778 -- | Validates the existence of an appropriate @hi@ file associated with
1779 -- a module. Used for both @hidden-modules@ and @exposed-modules@ which
1780 -- are not reexports.
1781 checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate ()
1782 checkModuleFile pkg modl =
1783 -- there's no interface file for GHC.Prim
1784 unless (modl == ModuleName.fromString "GHC.Prim") $ do
1785 let files = [ ModuleName.toFilePath modl <.> extension
1786 | extension <- ["hi", "p_hi", "dyn_hi" ] ]
1787 b <- liftIO $ doesFileExistOnPath files (importDirs pkg)
1788 when (not b) $
1789 verror ForceFiles ("cannot find any of " ++ show files)
1790
1791 -- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate
1792 -- entries.
1793 -- ToDo: this needs updating for signatures: signatures can validly show up
1794 -- multiple times in the @exposed-modules@ list as long as their backing
1795 -- implementations agree.
1796 checkDuplicateModules :: InstalledPackageInfo -> Validate ()
1797 checkDuplicateModules pkg
1798 | null dups = return ()
1799 | otherwise = verror ForceAll ("package has duplicate modules: " ++
1800 unwords (map display dups))
1801 where
1802 dups = [ m | (m:_:_) <- group (sort mods) ]
1803 mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg
1804
1805 -- | Validates an original module entry, either the origin of a module reexport
1806 -- or the backing implementation of a signature, by checking that it exists,
1807 -- really is an original definition, and is accessible from the dependencies of
1808 -- the package.
1809 -- ToDo: If the original module in question is a backing signature
1810 -- implementation, then we should also check that the original module in
1811 -- question is NOT a signature (however, if it is a reexport, then it's fine
1812 -- for the original module to be a signature.)
1813 checkModule :: String
1814 -> PackageDBStack
1815 -> InstalledPackageInfo
1816 -> OpenModule
1817 -> Validate ()
1818 checkModule _ _ _ (OpenModuleVar _) = error "Impermissible reexport"
1819 checkModule field_name db_stack pkg
1820 (OpenModule (DefiniteUnitId def_uid) definingModule) =
1821 let definingPkgId = unDefUnitId def_uid
1822 mpkg = if definingPkgId == installedUnitId pkg
1823 then Just pkg
1824 else PackageIndex.lookupUnitId ipix definingPkgId
1825 in case mpkg of
1826 Nothing
1827 -> verror ForceAll (field_name ++ " refers to a non-existent " ++
1828 "defining package: " ++
1829 display definingPkgId)
1830
1831 Just definingPkg
1832 | not (isIndirectDependency definingPkgId)
1833 -> verror ForceAll (field_name ++ " refers to a defining " ++
1834 "package that is not a direct (or indirect) " ++
1835 "dependency of this package: " ++
1836 display definingPkgId)
1837
1838 | otherwise
1839 -> case find ((==definingModule).exposedName)
1840 (exposedModules definingPkg) of
1841 Nothing ->
1842 verror ForceAll (field_name ++ " refers to a module " ++
1843 display definingModule ++ " " ++
1844 "that is not exposed in the " ++
1845 "defining package " ++ display definingPkgId)
1846 Just (ExposedModule {exposedReexport = Just _} ) ->
1847 verror ForceAll (field_name ++ " refers to a module " ++
1848 display definingModule ++ " " ++
1849 "that is reexported but not defined in the " ++
1850 "defining package " ++ display definingPkgId)
1851 _ -> return ()
1852 where
1853 all_pkgs = allPackagesInStack db_stack
1854 ipix = PackageIndex.fromList all_pkgs
1855
1856 isIndirectDependency pkgid = fromMaybe False $ do
1857 thispkg <- graphVertex (installedUnitId pkg)
1858 otherpkg <- graphVertex pkgid
1859 return (Graph.path depgraph thispkg otherpkg)
1860 (depgraph, _, graphVertex) =
1861 PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix)
1862
1863 checkModule _ _ _ (OpenModule (IndefFullUnitId _ _) _) =
1864 -- TODO: add some checks here
1865 return ()
1866
1867
1868 -- ---------------------------------------------------------------------------
1869 -- expanding environment variables in the package configuration
1870
1871 expandEnvVars :: String -> Force -> IO String
1872 expandEnvVars str0 force = go str0 ""
1873 where
1874 go "" acc = return $! reverse acc
1875 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1876 = do value <- lookupEnvVar var
1877 go rest (reverse value ++ acc)
1878 where close c = c == '}' || c == '\n' -- don't span newlines
1879 go (c:str) acc
1880 = go str (c:acc)
1881
1882 lookupEnvVar :: String -> IO String
1883 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1884 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1885 lookupEnvVar nm =
1886 catchIO (System.Environment.getEnv nm)
1887 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1888 show nm)
1889 return "")
1890
1891 -----------------------------------------------------------------------------
1892
1893 getProgramName :: IO String
1894 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1895 where str `withoutSuffix` suff
1896 | suff `isSuffixOf` str = take (length str - length suff) str
1897 | otherwise = str
1898
1899 bye :: String -> IO a
1900 bye s = putStr s >> exitWith ExitSuccess
1901
1902 die :: String -> IO a
1903 die = dieWith 1
1904
1905 dieWith :: Int -> String -> IO a
1906 dieWith ec s = do
1907 prog <- getProgramName
1908 reportError (prog ++ ": " ++ s)
1909 exitWith (ExitFailure ec)
1910
1911 dieOrForceAll :: Force -> String -> IO ()
1912 dieOrForceAll ForceAll s = ignoreError s
1913 dieOrForceAll _other s = dieForcible s
1914
1915 warn :: String -> IO ()
1916 warn = reportError
1917
1918 -- send info messages to stdout
1919 infoLn :: String -> IO ()
1920 infoLn = putStrLn
1921
1922 info :: String -> IO ()
1923 info = putStr
1924
1925 ignoreError :: String -> IO ()
1926 ignoreError s = reportError (s ++ " (ignoring)")
1927
1928 reportError :: String -> IO ()
1929 reportError s = do hFlush stdout; hPutStrLn stderr s
1930
1931 dieForcible :: String -> IO ()
1932 dieForcible s = die (s ++ " (use --force to override)")
1933
1934 my_head :: String -> [a] -> a
1935 my_head s [] = error s
1936 my_head _ (x : _) = x
1937
1938 -----------------------------------------
1939 -- Cut and pasted from ghc/compiler/main/SysTools
1940
1941 #if defined(mingw32_HOST_OS)
1942 subst :: Char -> Char -> String -> String
1943 subst a b ls = map (\ x -> if x == a then b else x) ls
1944
1945 unDosifyPath :: FilePath -> FilePath
1946 unDosifyPath xs = subst '\\' '/' xs
1947
1948 getLibDir :: IO (Maybe String)
1949 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1950
1951 -- (getExecDir cmd) returns the directory in which the current
1952 -- executable, which should be called 'cmd', is running
1953 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1954 -- you'll get "/a/b/c" back as the result
1955 getExecDir :: String -> IO (Maybe String)
1956 getExecDir cmd =
1957 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1958 where initN n = reverse . drop n . reverse
1959 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1960
1961 getExecPath :: IO (Maybe String)
1962 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1963 where
1964 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1965 ret <- c_GetModuleFileName nullPtr buf size
1966 case ret of
1967 0 -> return Nothing
1968 _ | ret < size -> fmap Just $ peekCWString buf
1969 | otherwise -> try_size (size * 2)
1970
1971 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1972 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1973 #else
1974 getLibDir :: IO (Maybe String)
1975 getLibDir = return Nothing
1976 #endif
1977
1978 -----------------------------------------
1979 -- Adapted from ghc/compiler/utils/Panic
1980
1981 installSignalHandlers :: IO ()
1982 installSignalHandlers = do
1983 threadid <- myThreadId
1984 let
1985 interrupt = Exception.throwTo threadid
1986 (Exception.ErrorCall "interrupted")
1987 --
1988 #if !defined(mingw32_HOST_OS)
1989 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1990 _ <- installHandler sigINT (Catch interrupt) Nothing
1991 return ()
1992 #else
1993 -- GHC 6.3+ has support for console events on Windows
1994 -- NOTE: running GHCi under a bash shell for some reason requires
1995 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1996 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1997 -- why --SDM 17/12/2004
1998 let sig_handler ControlC = interrupt
1999 sig_handler Break = interrupt
2000 sig_handler _ = return ()
2001
2002 _ <- installHandler (Catch sig_handler)
2003 return ()
2004 #endif
2005
2006 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
2007 catchIO = Exception.catch
2008
2009 tryIO :: IO a -> IO (Either Exception.IOException a)
2010 tryIO = Exception.try
2011
2012 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
2013 removeFileSafe :: FilePath -> IO ()
2014 removeFileSafe fn =
2015 removeFile fn `catchIO` \ e ->
2016 when (not $ isDoesNotExistError e) $ ioError e
2017
2018 -- | Turn a path relative to the current directory into a (normalised)
2019 -- absolute path.
2020 absolutePath :: FilePath -> IO FilePath
2021 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
2022
2023
2024 {- Note [writeAtomic leaky abstraction]
2025 GhcPkg.writePackageDb calls writeAtomic, which first writes to a temp file,
2026 and then moves the tempfile to its final destination. This all happens in the
2027 same directory (package.conf.d).
2028 Moving a file doesn't change its modification time, but it *does* change the
2029 modification time of the directory it is placed in. Since we compare the
2030 modification time of the cache file to that of the directory it is in to
2031 decide whether the cache is out-of-date, it will be instantly out-of-date
2032 after creation, if the renaming takes longer than the smallest time difference
2033 that the getModificationTime can measure.
2034
2035 The solution we opt for is a "touch" of the cache file right after it is
2036 created. This resets the modification time of the cache file and the directory
2037 to the current time.
2038
2039 Other possible solutions:
2040 * backdate the modification time of the directory to the modification time
2041 of the cachefile. This is what we used to do on posix platforms. An
2042 observer of the directory would see the modification time of the directory
2043 jump back in time. Not nice, although in practice probably not a problem.
2044 Also note that a cross-platform implementation of setModificationTime is
2045 currently not available.
2046 * set the modification time of the cache file to the modification time of
2047 the directory (instead of the curent time). This could also work,
2048 given that we are the only ones writing to this directory. It would also
2049 require a high-precision getModificationTime (lower precision times get
2050 rounded down it seems), or the cache would still be out-of-date.
2051 * change writeAtomic to create the tempfile outside of the target file's
2052 directory.
2053 * create the cachefile outside of the package.conf.d directory in the first
2054 place. But there are tests and there might be tools that currently rely on
2055 the package.conf.d/package.cache format.
2056 -}