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