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