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