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