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