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