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