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