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