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