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