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