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