Simplify conversion in binary serialisation of ghc-pkg db
[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 mkPackageDB pkgs
710 else do
711 when (verbosity >= Normal) $ do
712 warn ("WARNING: cache is out of date: "
713 ++ cache)
714 warn "Use 'ghc-pkg recache' to fix."
715 ignore_cache compareTimestampToCache
716 where
717 ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
718 ignore_cache checkTime = do
719 let confs = filter (".conf" `isSuffixOf`) fs
720 doFile f = do checkTime f
721 parseSingletonPackageConf verbosity f
722 pkgs <- mapM doFile $ map (path </>) confs
723 mkPackageDB pkgs
724 where
725 mkPackageDB pkgs = do
726 path_abs <- absolutePath path
727 return PackageDB {
728 location = path,
729 locationAbsolute = path_abs,
730 packages = pkgs
731 }
732
733 -- read the package.cache file strictly, to work around a problem with
734 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
735 -- after it has been completely read, leading to a sharing violation
736 -- later.
737 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfo]
738 myReadBinPackageDB filepath = do
739 h <- openBinaryFile filepath ReadMode
740 sz <- hFileSize h
741 b <- B.hGet h (fromIntegral sz)
742 hClose h
743 return $ Bin.runGet Bin.get b
744
745 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
746 parseMultiPackageConf verbosity file = do
747 when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
748 str <- readUTF8File file
749 let pkgs = map convertPackageInfoIn $ read str
750 Exception.evaluate pkgs
751 `catchError` \e->
752 die ("error while parsing " ++ file ++ ": " ++ show e)
753
754 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
755 parseSingletonPackageConf verbosity file = do
756 when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
757 readUTF8File file >>= fmap fst . parsePackageInfo
758
759 cachefilename :: FilePath
760 cachefilename = "package.cache"
761
762 mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
763 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
764 db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
765 where
766 pkgroot = takeDirectory (locationAbsolute db)
767 -- It so happens that for both styles of package db ("package.conf"
768 -- files and "package.conf.d" dirs) the pkgroot is the parent directory
769 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
770
771 -- TODO: This code is duplicated in compiler/main/Packages.lhs
772 mungePackagePaths :: FilePath -> FilePath
773 -> InstalledPackageInfo -> InstalledPackageInfo
774 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
775 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
776 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
777 -- The "pkgroot" is the directory containing the package database.
778 --
779 -- Also perform a similar substitution for the older GHC-specific
780 -- "$topdir" variable. The "topdir" is the location of the ghc
781 -- installation (obtained from the -B option).
782 mungePackagePaths top_dir pkgroot pkg =
783 pkg {
784 importDirs = munge_paths (importDirs pkg),
785 includeDirs = munge_paths (includeDirs pkg),
786 libraryDirs = munge_paths (libraryDirs pkg),
787 frameworkDirs = munge_paths (frameworkDirs pkg),
788 haddockInterfaces = munge_paths (haddockInterfaces pkg),
789 -- haddock-html is allowed to be either a URL or a file
790 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
791 }
792 where
793 munge_paths = map munge_path
794 munge_urls = map munge_url
795
796 munge_path p
797 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
798 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
799 | otherwise = p
800
801 munge_url p
802 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
803 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
804 | otherwise = p
805
806 toUrlPath r p = "file:///"
807 -- URLs always use posix style '/' separators:
808 ++ FilePath.Posix.joinPath
809 (r : -- We need to drop a leading "/" or "\\"
810 -- if there is one:
811 dropWhile (all isPathSeparator)
812 (FilePath.splitDirectories p))
813
814 -- We could drop the separator here, and then use </> above. However,
815 -- by leaving it in and using ++ we keep the same path separator
816 -- rather than letting FilePath change it to use \ as the separator
817 stripVarPrefix var path = case stripPrefix var path of
818 Just [] -> Just []
819 Just cs@(c : _) | isPathSeparator c -> Just cs
820 _ -> Nothing
821
822
823 -- -----------------------------------------------------------------------------
824 -- Creating a new package DB
825
826 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
827 initPackageDB filename verbosity _flags = do
828 let eexist = die ("cannot create: " ++ filename ++ " already exists")
829 b1 <- doesFileExist filename
830 when b1 eexist
831 b2 <- doesDirectoryExist filename
832 when b2 eexist
833 filename_abs <- absolutePath filename
834 changeDB verbosity [] PackageDB {
835 location = filename, locationAbsolute = filename_abs,
836 packages = []
837 }
838
839 -- -----------------------------------------------------------------------------
840 -- Registering
841
842 registerPackage :: FilePath
843 -> Verbosity
844 -> [Flag]
845 -> Bool -- auto_ghci_libs
846 -> Bool -- multi_instance
847 -> Bool -- expand_env_vars
848 -> Bool -- update
849 -> Force
850 -> IO ()
851 registerPackage input verbosity my_flags auto_ghci_libs multi_instance
852 expand_env_vars update force = do
853 (db_stack, Just to_modify, _flag_dbs) <-
854 getPkgDatabases verbosity True True False{-expand vars-} my_flags
855
856 let
857 db_to_operate_on = my_head "register" $
858 filter ((== to_modify).location) db_stack
859 --
860 when (auto_ghci_libs && verbosity >= Silent) $
861 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
862 --
863 s <-
864 case input of
865 "-" -> do
866 when (verbosity >= Normal) $
867 info "Reading package info from stdin ... "
868 -- fix the encoding to UTF-8, since this is an interchange format
869 hSetEncoding stdin utf8
870 getContents
871 f -> do
872 when (verbosity >= Normal) $
873 info ("Reading package info from " ++ show f ++ " ... ")
874 readUTF8File f
875
876 expanded <- if expand_env_vars then expandEnvVars s force
877 else return s
878
879 (pkg, ws) <- parsePackageInfo expanded
880 when (verbosity >= Normal) $
881 infoLn "done."
882
883 -- report any warnings from the parse phase
884 _ <- reportValidateErrors [] ws
885 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
886
887 -- validate the expanded pkg, but register the unexpanded
888 pkgroot <- absolutePath (takeDirectory to_modify)
889 let top_dir = takeDirectory (location (last db_stack))
890 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
891
892 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
893 -- truncate the stack for validation, because we don't allow
894 -- packages lower in the stack to refer to those higher up.
895 validatePackageConfig pkg_expanded verbosity truncated_stack
896 auto_ghci_libs multi_instance update force
897
898 -- postprocess the package
899 pkg' <- resolveReexports truncated_stack pkg
900
901 let
902 -- In the normal mode, we only allow one version of each package, so we
903 -- remove all instances with the same source package id as the one we're
904 -- adding. In the multi instance mode we don't do that, thus allowing
905 -- multiple instances with the same source package id.
906 removes = [ RemovePackage p
907 | not multi_instance,
908 p <- packages db_to_operate_on,
909 sourcePackageId p == sourcePackageId pkg ]
910 --
911 changeDB verbosity (removes ++ [AddPackage pkg']) db_to_operate_on
912
913 parsePackageInfo
914 :: String
915 -> IO (InstalledPackageInfo, [ValidateWarning])
916 parsePackageInfo str =
917 case parseInstalledPackageInfo str of
918 ParseOk warnings ok -> return (mungePackageInfo ok, ws)
919 where
920 ws = [ msg | PWarning msg <- warnings
921 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
922 ParseFailed err -> case locatedErrorMsg err of
923 (Nothing, s) -> die s
924 (Just l, s) -> die (show l ++ ": " ++ s)
925
926 mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo
927 mungePackageInfo ipi = ipi { packageKey = packageKey' }
928 where
929 packageKey'
930 | OldPackageKey (PackageIdentifier (PackageName "") _) <- packageKey ipi
931 = OldPackageKey (sourcePackageId ipi)
932 | otherwise = packageKey ipi
933
934 -- | Takes the "reexported-modules" field of an InstalledPackageInfo
935 -- and resolves the references so they point to the original exporter
936 -- of a module (i.e. the module is in exposed-modules, not
937 -- reexported-modules). This is done by maintaining an invariant on
938 -- the installed package database that a reexported-module field always
939 -- points to the original exporter.
940 resolveReexports :: PackageDBStack
941 -> InstalledPackageInfo
942 -> IO InstalledPackageInfo
943 resolveReexports db_stack pkg = do
944 let dep_mask = Set.fromList (depends pkg)
945 deps = filter (flip Set.member dep_mask . installedPackageId)
946 (allPackagesInStack db_stack)
947 matchExposed pkg_dep m = map ((,) (installedPackageId pkg_dep))
948 (filter (==m) (exposedModules pkg_dep))
949 worker ModuleExport{ exportOrigPackageName = Just pnm } pkg_dep
950 | pnm /= packageName (sourcePackageId pkg_dep) = []
951 -- Now, either the package matches, *or* we were asked to search the
952 -- true location ourselves.
953 worker ModuleExport{ exportOrigName = m } pkg_dep =
954 matchExposed pkg_dep m ++
955 map (fromMaybe (error $ "Impossible! Missing true location in " ++
956 display (installedPackageId pkg_dep))
957 . exportCachedTrueOrig)
958 (filter ((==m) . exportName) (reexportedModules pkg_dep))
959 self_reexports ModuleExport{ exportOrigPackageName = Just pnm }
960 | pnm /= packageName (sourcePackageId pkg) = []
961 self_reexports ModuleExport{ exportName = m', exportOrigName = m }
962 -- Self-reexport without renaming doesn't make sense
963 | m == m' = []
964 -- *Only* match against exposed modules!
965 | otherwise = matchExposed pkg m
966
967 r <- forM (reexportedModules pkg) $ \me -> do
968 case nub (concatMap (worker me) deps ++ self_reexports me) of
969 [c] -> return me { exportCachedTrueOrig = Just c }
970 [] -> die $ "Couldn't resolve reexport " ++ display me
971 cs -> die $ "Found multiple possible ways to resolve reexport " ++
972 display me ++ ": " ++ show cs
973 return (pkg { reexportedModules = r })
974
975 -- -----------------------------------------------------------------------------
976 -- Making changes to a package database
977
978 data DBOp = RemovePackage InstalledPackageInfo
979 | AddPackage InstalledPackageInfo
980 | ModifyPackage InstalledPackageInfo
981
982 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
983 changeDB verbosity cmds db = do
984 let db' = updateInternalDB db cmds
985 isfile <- doesFileExist (location db)
986 if isfile
987 then writeNewConfig verbosity (location db') (packages db')
988 else do
989 createDirectoryIfMissing True (location db)
990 changeDBDir verbosity cmds db'
991
992 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
993 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
994 where
995 do_cmd pkgs (RemovePackage p) =
996 filter ((/= installedPackageId p) . installedPackageId) pkgs
997 do_cmd pkgs (AddPackage p) = p : pkgs
998 do_cmd pkgs (ModifyPackage p) =
999 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
1000
1001
1002 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
1003 changeDBDir verbosity cmds db = do
1004 mapM_ do_cmd cmds
1005 updateDBCache verbosity db
1006 where
1007 do_cmd (RemovePackage p) = do
1008 let file = location db </> display (installedPackageId p) <.> "conf"
1009 when (verbosity > Normal) $ infoLn ("removing " ++ file)
1010 removeFileSafe file
1011 do_cmd (AddPackage p) = do
1012 let file = location db </> display (installedPackageId p) <.> "conf"
1013 when (verbosity > Normal) $ infoLn ("writing " ++ file)
1014 writeFileUtf8Atomic file (showInstalledPackageInfo p)
1015 do_cmd (ModifyPackage p) =
1016 do_cmd (AddPackage p)
1017
1018 updateDBCache :: Verbosity -> PackageDB -> IO ()
1019 updateDBCache verbosity db = do
1020 let filename = location db </> cachefilename
1021 when (verbosity > Normal) $
1022 infoLn ("writing cache " ++ filename)
1023 writeBinaryFileAtomic filename (packages db)
1024 `catchIO` \e ->
1025 if isPermissionError e
1026 then die (filename ++ ": you don't have permission to modify this file")
1027 else ioError e
1028 #ifndef mingw32_HOST_OS
1029 status <- getFileStatus filename
1030 setFileTimes (location db) (accessTime status) (modificationTime status)
1031 #endif
1032
1033 -- -----------------------------------------------------------------------------
1034 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
1035
1036 exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1037 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
1038
1039 hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1040 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
1041
1042 trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1043 trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
1044
1045 distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1046 distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
1047
1048 unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1049 unregisterPackage = modifyPackage RemovePackage
1050
1051 modifyPackage
1052 :: (InstalledPackageInfo -> DBOp)
1053 -> PackageArg
1054 -> Verbosity
1055 -> [Flag]
1056 -> Force
1057 -> IO ()
1058 modifyPackage fn pkgarg verbosity my_flags force = do
1059 (db_stack, Just _to_modify, flag_dbs) <-
1060 getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
1061
1062 -- Do the search for the package respecting flags...
1063 (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg
1064 let
1065 db_name = location db
1066 pkgs = packages db
1067
1068 pks = map packageKey ps
1069
1070 cmds = [ fn pkg | pkg <- pkgs, packageKey pkg `elem` pks ]
1071 new_db = updateInternalDB db cmds
1072
1073 -- ...but do consistency checks with regards to the full stack
1074 old_broken = brokenPackages (allPackagesInStack db_stack)
1075 rest_of_stack = filter ((/= db_name) . location) db_stack
1076 new_stack = new_db : rest_of_stack
1077 new_broken = brokenPackages (allPackagesInStack new_stack)
1078 newly_broken = filter ((`notElem` map packageKey old_broken)
1079 . packageKey) new_broken
1080 --
1081 let displayQualPkgId pkg
1082 | [_] <- filter ((== pkgid) . sourcePackageId)
1083 (allPackagesInStack db_stack)
1084 = display pkgid
1085 | otherwise = display pkgid ++ "@" ++ display (packageKey pkg)
1086 where pkgid = sourcePackageId pkg
1087 when (not (null newly_broken)) $
1088 dieOrForceAll force ("unregistering would break the following packages: "
1089 ++ unwords (map displayQualPkgId newly_broken))
1090
1091 changeDB verbosity cmds db
1092
1093 recache :: Verbosity -> [Flag] -> IO ()
1094 recache verbosity my_flags = do
1095 (db_stack, Just to_modify, _flag_dbs) <-
1096 getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
1097 let
1098 db_to_operate_on = my_head "recache" $
1099 filter ((== to_modify).location) db_stack
1100 --
1101 changeDB verbosity [] db_to_operate_on
1102
1103 -- -----------------------------------------------------------------------------
1104 -- Listing packages
1105
1106 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
1107 -> Maybe (String->Bool)
1108 -> IO ()
1109 listPackages verbosity my_flags mPackageName mModuleName = do
1110 let simple_output = FlagSimpleOutput `elem` my_flags
1111 (db_stack, _, flag_db_stack) <-
1112 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1113
1114 let db_stack_filtered -- if a package is given, filter out all other packages
1115 | Just this <- mPackageName =
1116 [ db{ packages = filter (this `matchesPkg`) (packages db) }
1117 | db <- flag_db_stack ]
1118 | Just match <- mModuleName = -- packages which expose mModuleName
1119 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
1120 | db <- flag_db_stack ]
1121 | otherwise = flag_db_stack
1122
1123 db_stack_sorted
1124 = [ db{ packages = sort_pkgs (packages db) }
1125 | db <- db_stack_filtered ]
1126 where sort_pkgs = sortBy cmpPkgIds
1127 cmpPkgIds pkg1 pkg2 =
1128 case pkgName p1 `compare` pkgName p2 of
1129 LT -> LT
1130 GT -> GT
1131 EQ -> case pkgVersion p1 `compare` pkgVersion p2 of
1132 LT -> LT
1133 GT -> GT
1134 EQ -> packageKey pkg1 `compare` packageKey pkg2
1135 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
1136
1137 stack = reverse db_stack_sorted
1138
1139 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
1140
1141 pkg_map = allPackagesInStack db_stack
1142 broken = map packageKey (brokenPackages pkg_map)
1143
1144 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
1145 do hPutStrLn stdout (db_name ++ ":")
1146 if null pp_pkgs
1147 then hPutStrLn stdout " (no packages)"
1148 else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs)
1149 where
1150 -- Sort using instance Ord PackageId
1151 pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs
1152 pp_pkg p
1153 | packageKey p `elem` broken = printf "{%s}" doc
1154 | exposed p = doc
1155 | otherwise = printf "(%s)" doc
1156 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
1157 | otherwise = pkg
1158 where
1159 InstalledPackageId ipid = installedPackageId p
1160 pkg = display (sourcePackageId p)
1161
1162 show_simple = simplePackageList my_flags . allPackagesInStack
1163
1164 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
1165 prog <- getProgramName
1166 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
1167
1168 if simple_output then show_simple stack else do
1169
1170 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
1171 mapM_ show_normal stack
1172 #else
1173 let
1174 show_colour withF db =
1175 mconcat $ map (<#> termText "\n") $
1176 (termText (location db) :
1177 map (termText " " <#>) (map pp_pkg (packages db)))
1178 where
1179 pp_pkg p
1180 | packageKey p `elem` broken = withF Red doc
1181 | exposed p = doc
1182 | otherwise = withF Blue doc
1183 where doc | verbosity >= Verbose
1184 = termText (printf "%s (%s)" pkg ipid)
1185 | otherwise
1186 = termText pkg
1187 where
1188 InstalledPackageId ipid = installedPackageId p
1189 pkg = display (sourcePackageId p)
1190
1191 is_tty <- hIsTerminalDevice stdout
1192 if not is_tty
1193 then mapM_ show_normal stack
1194 else do tty <- Terminfo.setupTermFromEnv
1195 case Terminfo.getCapability tty withForegroundColor of
1196 Nothing -> mapM_ show_normal stack
1197 Just w -> runTermOutput tty $ mconcat $
1198 map (show_colour w) stack
1199 #endif
1200
1201 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1202 simplePackageList my_flags pkgs = do
1203 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1204 else display
1205 -- Sort using instance Ord PackageId
1206 strs = map showPkg $ sort $ map sourcePackageId pkgs
1207 when (not (null pkgs)) $
1208 hPutStrLn stdout $ concat $ intersperse " " strs
1209
1210 showPackageDot :: Verbosity -> [Flag] -> IO ()
1211 showPackageDot verbosity myflags = do
1212 (_, _, flag_db_stack) <-
1213 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
1214
1215 let all_pkgs = allPackagesInStack flag_db_stack
1216 ipix = PackageIndex.fromList all_pkgs
1217
1218 putStrLn "digraph {"
1219 let quote s = '"':s ++ "\""
1220 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1221 | p <- all_pkgs,
1222 let from = display (sourcePackageId p),
1223 depid <- depends p,
1224 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1225 let to = display (sourcePackageId dep)
1226 ]
1227 putStrLn "}"
1228
1229 -- -----------------------------------------------------------------------------
1230 -- Prints the highest (hidden or exposed) version of a package
1231
1232 -- ToDo: This is no longer well-defined with package keys, because the
1233 -- dependencies may be varying versions
1234 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1235 latestPackage verbosity my_flags pkgid = do
1236 (_, _, flag_db_stack) <-
1237 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1238
1239 ps <- findPackages flag_db_stack (Id pkgid)
1240 case ps of
1241 [] -> die "no matches"
1242 _ -> show_pkg . maximum . map sourcePackageId $ ps
1243 where
1244 show_pkg pid = hPutStrLn stdout (display pid)
1245
1246 -- -----------------------------------------------------------------------------
1247 -- Describe
1248
1249 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1250 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1251 (_, _, flag_db_stack) <-
1252 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1253 dbs <- findPackagesByDB flag_db_stack pkgarg
1254 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1255 | (db, pkgs) <- dbs, pkg <- pkgs ]
1256
1257 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1258 dumpPackages verbosity my_flags expand_pkgroot = do
1259 (_, _, flag_db_stack) <-
1260 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1261 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1262 | db <- flag_db_stack, pkg <- packages db ]
1263
1264 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1265 doDump expand_pkgroot pkgs = do
1266 -- fix the encoding to UTF-8, since this is an interchange format
1267 hSetEncoding stdout utf8
1268 putStrLn $
1269 intercalate "---\n"
1270 [ if expand_pkgroot
1271 then showInstalledPackageInfo pkg
1272 else showInstalledPackageInfo pkg ++ pkgrootField
1273 | (pkg, pkgloc) <- pkgs
1274 , let pkgroot = takeDirectory pkgloc
1275 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
1276
1277 -- PackageId is can have globVersion for the version
1278 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1279 findPackages db_stack pkgarg
1280 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1281
1282 findPackagesByDB :: PackageDBStack -> PackageArg
1283 -> IO [(PackageDB, [InstalledPackageInfo])]
1284 findPackagesByDB db_stack pkgarg
1285 = case [ (db, matched)
1286 | db <- db_stack,
1287 let matched = filter (pkgarg `matchesPkg`) (packages db),
1288 not (null matched) ] of
1289 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1290 ps -> return ps
1291 where
1292 pkg_msg (Id pkgid) = display pkgid
1293 pkg_msg (IPId ipid) = display ipid
1294 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1295
1296 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1297 pid `matches` pid'
1298 = (pkgName pid == pkgName pid')
1299 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1300
1301 realVersion :: PackageIdentifier -> Bool
1302 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1303 -- when versionBranch == [], this is a glob
1304
1305 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1306 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1307 (IPId ipid) `matchesPkg` pkg = ipid == installedPackageId pkg
1308 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1309
1310 -- -----------------------------------------------------------------------------
1311 -- Field
1312
1313 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1314 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1315 (_, _, flag_db_stack) <-
1316 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1317 fns <- mapM toField fields
1318 ps <- findPackages flag_db_stack pkgarg
1319 mapM_ (selectFields fns) ps
1320 where showFun = if FlagSimpleOutput `elem` my_flags
1321 then showSimpleInstalledPackageInfoField
1322 else showInstalledPackageInfoField
1323 toField f = case showFun f of
1324 Nothing -> die ("unknown field: " ++ f)
1325 Just fn -> return fn
1326 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
1327
1328
1329 -- -----------------------------------------------------------------------------
1330 -- Check: Check consistency of installed packages
1331
1332 checkConsistency :: Verbosity -> [Flag] -> IO ()
1333 checkConsistency verbosity my_flags = do
1334 (db_stack, _, _) <-
1335 getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
1336 -- check behaves like modify for the purposes of deciding which
1337 -- databases to use, because ordering is important.
1338
1339 let simple_output = FlagSimpleOutput `elem` my_flags
1340
1341 let pkgs = allPackagesInStack db_stack
1342
1343 checkPackage p = do
1344 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
1345 False True True
1346 if null es
1347 then do when (not simple_output) $ do
1348 _ <- reportValidateErrors [] ws "" Nothing
1349 return ()
1350 return []
1351 else do
1352 when (not simple_output) $ do
1353 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1354 _ <- reportValidateErrors es ws " " Nothing
1355 return ()
1356 return [p]
1357
1358 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1359
1360 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1361 where not_in p = sourcePackageId p `notElem` all_ps
1362 all_ps = map sourcePackageId pkgs1
1363
1364 let not_broken_pkgs = filterOut broken_pkgs pkgs
1365 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1366 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1367
1368 when (not (null all_broken_pkgs)) $ do
1369 if simple_output
1370 then simplePackageList my_flags all_broken_pkgs
1371 else do
1372 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1373 "listed above, or because they depend on a broken package.")
1374 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1375
1376 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1377
1378
1379 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1380 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1381 closure pkgs db_stack = go pkgs db_stack
1382 where
1383 go avail not_avail =
1384 case partition (depsAvailable avail) not_avail of
1385 ([], not_avail') -> (avail, not_avail')
1386 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1387
1388 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1389 -> Bool
1390 depsAvailable pkgs_ok pkg = null dangling
1391 where dangling = filter (`notElem` pids) (depends pkg)
1392 pids = map installedPackageId pkgs_ok
1393
1394 -- we want mutually recursive groups of package to show up
1395 -- as broken. (#1750)
1396
1397 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1398 brokenPackages pkgs = snd (closure [] pkgs)
1399
1400 -- -----------------------------------------------------------------------------
1401 -- Manipulating package.conf files
1402
1403 type InstalledPackageInfoString = InstalledPackageInfo_ String
1404
1405 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1406 convertPackageInfoOut
1407 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1408 reexportedModules = r,
1409 hiddenModules = h })) =
1410 pkgconf{ exposedModules = map display e,
1411 reexportedModules = map (fmap display) r,
1412 hiddenModules = map display h }
1413
1414 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1415 convertPackageInfoIn
1416 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1417 reexportedModules = r,
1418 hiddenModules = h })) =
1419 pkgconf{ exposedModules = map convert e,
1420 reexportedModules = map (fmap convert) r,
1421 hiddenModules = map convert h }
1422 where convert = fromJust . simpleParse
1423
1424 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1425 writeNewConfig verbosity filename ipis = do
1426 when (verbosity >= Normal) $
1427 info "Writing new package config file... "
1428 createDirectoryIfMissing True $ takeDirectory filename
1429 let shown = concat $ intersperse ",\n "
1430 $ map (show . convertPackageInfoOut) ipis
1431 fileContents = "[" ++ shown ++ "\n]"
1432 writeFileUtf8Atomic filename fileContents
1433 `catchIO` \e ->
1434 if isPermissionError e
1435 then die (filename ++ ": you don't have permission to modify this file")
1436 else ioError e
1437 when (verbosity >= Normal) $
1438 infoLn "done."
1439
1440 -----------------------------------------------------------------------------
1441 -- Sanity-check a new package config, and automatically build GHCi libs
1442 -- if requested.
1443
1444 type ValidateError = (Force,String)
1445 type ValidateWarning = String
1446
1447 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1448
1449 instance Functor Validate where
1450 fmap = liftM
1451
1452 instance Applicative Validate where
1453 pure = return
1454 (<*>) = ap
1455
1456 instance Monad Validate where
1457 return a = V $ return (a, [], [])
1458 m >>= k = V $ do
1459 (a, es, ws) <- runValidate m
1460 (b, es', ws') <- runValidate (k a)
1461 return (b,es++es',ws++ws')
1462
1463 verror :: Force -> String -> Validate ()
1464 verror f s = V (return ((),[(f,s)],[]))
1465
1466 vwarn :: String -> Validate ()
1467 vwarn s = V (return ((),[],["Warning: " ++ s]))
1468
1469 liftIO :: IO a -> Validate a
1470 liftIO k = V (k >>= \a -> return (a,[],[]))
1471
1472 -- returns False if we should die
1473 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1474 -> String -> Maybe Force -> IO Bool
1475 reportValidateErrors es ws prefix mb_force = do
1476 mapM_ (warn . (prefix++)) ws
1477 oks <- mapM report es
1478 return (and oks)
1479 where
1480 report (f,s)
1481 | Just force <- mb_force
1482 = if (force >= f)
1483 then do reportError (prefix ++ s ++ " (ignoring)")
1484 return True
1485 else if f < CannotForce
1486 then do reportError (prefix ++ s ++ " (use --force to override)")
1487 return False
1488 else do reportError err
1489 return False
1490 | otherwise = do reportError err
1491 return False
1492 where
1493 err = prefix ++ s
1494
1495 validatePackageConfig :: InstalledPackageInfo
1496 -> Verbosity
1497 -> PackageDBStack
1498 -> Bool -- auto-ghc-libs
1499 -> Bool -- multi_instance
1500 -> Bool -- update, or check
1501 -> Force
1502 -> IO ()
1503 validatePackageConfig pkg verbosity db_stack auto_ghci_libs
1504 multi_instance update force = do
1505 (_,es,ws) <- runValidate $
1506 checkPackageConfig pkg verbosity db_stack
1507 auto_ghci_libs multi_instance update
1508 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1509 when (not ok) $ exitWith (ExitFailure 1)
1510
1511 checkPackageConfig :: InstalledPackageInfo
1512 -> Verbosity
1513 -> PackageDBStack
1514 -> Bool -- auto-ghc-libs
1515 -> Bool -- multi_instance
1516 -> Bool -- update, or check
1517 -> Validate ()
1518 checkPackageConfig pkg verbosity db_stack auto_ghci_libs
1519 multi_instance update = do
1520 checkInstalledPackageId pkg db_stack update
1521 checkPackageId pkg
1522 checkPackageKey pkg
1523 checkDuplicates db_stack pkg multi_instance update
1524 mapM_ (checkDep db_stack) (depends pkg)
1525 checkDuplicateDepends (depends pkg)
1526 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1527 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1528 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1529 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1530 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1531 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1532 checkModules pkg
1533 mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1534 -- ToDo: check these somehow?
1535 -- extra_libraries :: [String],
1536 -- c_includes :: [String],
1537
1538 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1539 -> Validate ()
1540 checkInstalledPackageId ipi db_stack update = do
1541 let ipid@(InstalledPackageId str) = installedPackageId ipi
1542 when (null str) $ verror CannotForce "missing id field"
1543 let dups = [ p | p <- allPackagesInStack db_stack,
1544 installedPackageId p == ipid ]
1545 when (not update && not (null dups)) $
1546 verror CannotForce $
1547 "package(s) with this id already exist: " ++
1548 unwords (map (display.packageId) dups)
1549
1550 -- When the package name and version are put together, sometimes we can
1551 -- end up with a package id that cannot be parsed. This will lead to
1552 -- difficulties when the user wants to refer to the package later, so
1553 -- we check that the package id can be parsed properly here.
1554 checkPackageId :: InstalledPackageInfo -> Validate ()
1555 checkPackageId ipi =
1556 let str = display (sourcePackageId ipi) in
1557 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1558 [_] -> return ()
1559 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1560 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1561
1562 checkPackageKey :: InstalledPackageInfo -> Validate ()
1563 checkPackageKey ipi =
1564 let str = display (packageKey ipi) in
1565 case [ x :: PackageKey | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1566 [_] -> return ()
1567 [] -> verror CannotForce ("invalid package key: " ++ str)
1568 _ -> verror CannotForce ("ambiguous package key: " ++ str)
1569
1570 checkDuplicates :: PackageDBStack -> InstalledPackageInfo
1571 -> Bool -> Bool-> Validate ()
1572 checkDuplicates db_stack pkg multi_instance update = do
1573 let
1574 pkgid = sourcePackageId pkg
1575 pkgs = packages (head db_stack)
1576 --
1577 -- Check whether this package id already exists in this DB
1578 --
1579 when (not update && not multi_instance
1580 && (pkgid `elem` map sourcePackageId pkgs)) $
1581 verror CannotForce $
1582 "package " ++ display pkgid ++ " is already installed"
1583
1584 let
1585 uncasep = map toLower . display
1586 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1587
1588 when (not update && not (null dups)) $ verror ForceAll $
1589 "Package names may be treated case-insensitively in the future.\n"++
1590 "Package " ++ display pkgid ++
1591 " overlaps with: " ++ unwords (map display dups)
1592
1593 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1594 checkDir = checkPath False True
1595 checkFile = checkPath False False
1596 checkDirURL = checkPath True True
1597
1598 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1599 checkPath url_ok is_dir warn_only thisfield d
1600 | url_ok && ("http://" `isPrefixOf` d
1601 || "https://" `isPrefixOf` d) = return ()
1602
1603 | url_ok
1604 , Just d' <- stripPrefix "file://" d
1605 = checkPath False is_dir warn_only thisfield d'
1606
1607 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1608 -- variables having been expanded already, see mungePackagePaths.
1609
1610 | isRelative d = verror ForceFiles $
1611 thisfield ++ ": " ++ d ++ " is a relative path which "
1612 ++ "makes no sense (as there is nothing for it to be "
1613 ++ "relative to). You can make paths relative to the "
1614 ++ "package database itself by using ${pkgroot}."
1615 -- relative paths don't make any sense; #4134
1616 | otherwise = do
1617 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1618 when (not there) $
1619 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1620 ++ if is_dir then "directory" else "file"
1621 in
1622 if warn_only
1623 then vwarn msg
1624 else verror ForceFiles msg
1625
1626 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1627 checkDep db_stack pkgid
1628 | pkgid `elem` pkgids = return ()
1629 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1630 ++ "\" doesn't exist")
1631 where
1632 all_pkgs = allPackagesInStack db_stack
1633 pkgids = map installedPackageId all_pkgs
1634
1635 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1636 checkDuplicateDepends deps
1637 | null dups = return ()
1638 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1639 unwords (map display dups))
1640 where
1641 dups = [ p | (p:_:_) <- group (sort deps) ]
1642
1643 checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
1644 checkHSLib verbosity dirs auto_ghci_libs lib = do
1645 let batch_lib_file = "lib" ++ lib ++ ".a"
1646 filenames = ["lib" ++ lib ++ ".a",
1647 "lib" ++ lib ++ ".p_a",
1648 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so",
1649 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib",
1650 lib ++ "-ghc" ++ Version.version ++ ".dll"]
1651 m <- liftIO $ doesFileExistOnPath filenames dirs
1652 case m of
1653 Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++
1654 " on library path")
1655 Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
1656
1657 doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath)
1658 doesFileExistOnPath filenames paths = go fullFilenames
1659 where fullFilenames = [ (path, path </> filename)
1660 | filename <- filenames
1661 , path <- paths ]
1662 go [] = return Nothing
1663 go ((p, fp) : xs) = do b <- doesFileExist fp
1664 if b then return (Just p) else go xs
1665
1666 -- XXX maybe should check reexportedModules too
1667 checkModules :: InstalledPackageInfo -> Validate ()
1668 checkModules pkg = do
1669 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1670 where
1671 findModule modl =
1672 -- there's no interface file for GHC.Prim
1673 unless (modl == fromString "GHC.Prim") $ do
1674 let files = [ toFilePath modl <.> extension
1675 | extension <- ["hi", "p_hi", "dyn_hi" ] ]
1676 m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
1677 when (isNothing m) $
1678 verror ForceFiles ("cannot find any of " ++ show files)
1679
1680 checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
1681 checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
1682 | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
1683 | otherwise = return ()
1684 where
1685 ghci_lib_file = lib <.> "o"
1686
1687 -- automatically build the GHCi version of a batch lib,
1688 -- using ld --whole-archive.
1689
1690 autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
1691 autoBuildGHCiLib verbosity dir batch_file ghci_file = do
1692 let ghci_lib_file = dir ++ '/':ghci_file
1693 batch_lib_file = dir ++ '/':batch_file
1694 when (verbosity >= Normal) $
1695 info ("building GHCi library " ++ ghci_lib_file ++ "...")
1696 #if defined(darwin_HOST_OS)
1697 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1698 #elif defined(mingw32_HOST_OS)
1699 execDir <- getLibDir
1700 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1701 #else
1702 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1703 #endif
1704 when (r /= ExitSuccess) $ exitWith r
1705 when (verbosity >= Normal) $
1706 infoLn (" done.")
1707
1708 -- -----------------------------------------------------------------------------
1709 -- Searching for modules
1710
1711 #if not_yet
1712
1713 findModules :: [FilePath] -> IO [String]
1714 findModules paths =
1715 mms <- mapM searchDir paths
1716 return (concat mms)
1717
1718 searchDir path prefix = do
1719 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1720 searchEntries path prefix fs
1721
1722 searchEntries path prefix [] = return []
1723 searchEntries path prefix (f:fs)
1724 | looks_like_a_module = do
1725 ms <- searchEntries path prefix fs
1726 return (prefix `joinModule` f : ms)
1727 | looks_like_a_component = do
1728 ms <- searchDir (path </> f) (prefix `joinModule` f)
1729 ms' <- searchEntries path prefix fs
1730 return (ms ++ ms')
1731 | otherwise
1732 searchEntries path prefix fs
1733
1734 where
1735 (base,suffix) = splitFileExt f
1736 looks_like_a_module =
1737 suffix `elem` haskell_suffixes &&
1738 all okInModuleName base
1739 looks_like_a_component =
1740 null suffix && all okInModuleName base
1741
1742 okInModuleName c
1743
1744 #endif
1745
1746 -- ---------------------------------------------------------------------------
1747 -- expanding environment variables in the package configuration
1748
1749 expandEnvVars :: String -> Force -> IO String
1750 expandEnvVars str0 force = go str0 ""
1751 where
1752 go "" acc = return $! reverse acc
1753 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1754 = do value <- lookupEnvVar var
1755 go rest (reverse value ++ acc)
1756 where close c = c == '}' || c == '\n' -- don't span newlines
1757 go (c:str) acc
1758 = go str (c:acc)
1759
1760 lookupEnvVar :: String -> IO String
1761 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1762 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1763 lookupEnvVar nm =
1764 catchIO (System.Environment.getEnv nm)
1765 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1766 show nm)
1767 return "")
1768
1769 -----------------------------------------------------------------------------
1770
1771 getProgramName :: IO String
1772 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1773 where str `withoutSuffix` suff
1774 | suff `isSuffixOf` str = take (length str - length suff) str
1775 | otherwise = str
1776
1777 bye :: String -> IO a
1778 bye s = putStr s >> exitWith ExitSuccess
1779
1780 die :: String -> IO a
1781 die = dieWith 1
1782
1783 dieWith :: Int -> String -> IO a
1784 dieWith ec s = do
1785 prog <- getProgramName
1786 reportError (prog ++ ": " ++ s)
1787 exitWith (ExitFailure ec)
1788
1789 dieOrForceAll :: Force -> String -> IO ()
1790 dieOrForceAll ForceAll s = ignoreError s
1791 dieOrForceAll _other s = dieForcible s
1792
1793 warn :: String -> IO ()
1794 warn = reportError
1795
1796 -- send info messages to stdout
1797 infoLn :: String -> IO ()
1798 infoLn = putStrLn
1799
1800 info :: String -> IO ()
1801 info = putStr
1802
1803 ignoreError :: String -> IO ()
1804 ignoreError s = reportError (s ++ " (ignoring)")
1805
1806 reportError :: String -> IO ()
1807 reportError s = do hFlush stdout; hPutStrLn stderr s
1808
1809 dieForcible :: String -> IO ()
1810 dieForcible s = die (s ++ " (use --force to override)")
1811
1812 my_head :: String -> [a] -> a
1813 my_head s [] = error s
1814 my_head _ (x : _) = x
1815
1816 -----------------------------------------
1817 -- Cut and pasted from ghc/compiler/main/SysTools
1818
1819 #if defined(mingw32_HOST_OS)
1820 subst :: Char -> Char -> String -> String
1821 subst a b ls = map (\ x -> if x == a then b else x) ls
1822
1823 unDosifyPath :: FilePath -> FilePath
1824 unDosifyPath xs = subst '\\' '/' xs
1825
1826 getLibDir :: IO (Maybe String)
1827 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1828
1829 -- (getExecDir cmd) returns the directory in which the current
1830 -- executable, which should be called 'cmd', is running
1831 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1832 -- you'll get "/a/b/c" back as the result
1833 getExecDir :: String -> IO (Maybe String)
1834 getExecDir cmd =
1835 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1836 where initN n = reverse . drop n . reverse
1837 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1838
1839 getExecPath :: IO (Maybe String)
1840 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1841 where
1842 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1843 ret <- c_GetModuleFileName nullPtr buf size
1844 case ret of
1845 0 -> return Nothing
1846 _ | ret < size -> fmap Just $ peekCWString buf
1847 | otherwise -> try_size (size * 2)
1848
1849 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1850 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1851 #else
1852 getLibDir :: IO (Maybe String)
1853 getLibDir = return Nothing
1854 #endif
1855
1856 -----------------------------------------
1857 -- Adapted from ghc/compiler/utils/Panic
1858
1859 installSignalHandlers :: IO ()
1860 installSignalHandlers = do
1861 threadid <- myThreadId
1862 let
1863 interrupt = Exception.throwTo threadid
1864 (Exception.ErrorCall "interrupted")
1865 --
1866 #if !defined(mingw32_HOST_OS)
1867 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1868 _ <- installHandler sigINT (Catch interrupt) Nothing
1869 return ()
1870 #else
1871 -- GHC 6.3+ has support for console events on Windows
1872 -- NOTE: running GHCi under a bash shell for some reason requires
1873 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1874 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1875 -- why --SDM 17/12/2004
1876 let sig_handler ControlC = interrupt
1877 sig_handler Break = interrupt
1878 sig_handler _ = return ()
1879
1880 _ <- installHandler (Catch sig_handler)
1881 return ()
1882 #endif
1883
1884 #if mingw32_HOST_OS || mingw32_TARGET_OS
1885 throwIOIO :: Exception.IOException -> IO a
1886 throwIOIO = Exception.throwIO
1887 #endif
1888
1889 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1890 catchIO = Exception.catch
1891
1892 catchError :: IO a -> (String -> IO a) -> IO a
1893 catchError io handler = io `Exception.catch` handler'
1894 where handler' (Exception.ErrorCall err) = handler err
1895
1896 tryIO :: IO a -> IO (Either Exception.IOException a)
1897 tryIO = Exception.try
1898
1899 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1900 writeBinaryFileAtomic targetFile obj =
1901 withFileAtomic targetFile $ \h -> do
1902 hSetBinaryMode h True
1903 B.hPutStr h (Bin.encode obj)
1904
1905 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1906 writeFileUtf8Atomic targetFile content =
1907 withFileAtomic targetFile $ \h -> do
1908 hSetEncoding h utf8
1909 hPutStr h content
1910
1911 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1912 -- to use text files here, rather than binary files.
1913 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1914 withFileAtomic targetFile write_content = do
1915 (newFile, newHandle) <- openNewFile targetDir template
1916 do write_content newHandle
1917 hClose newHandle
1918 #if mingw32_HOST_OS || mingw32_TARGET_OS
1919 renameFile newFile targetFile
1920 -- If the targetFile exists then renameFile will fail
1921 `catchIO` \err -> do
1922 exists <- doesFileExist targetFile
1923 if exists
1924 then do removeFileSafe targetFile
1925 -- Big fat hairy race condition
1926 renameFile newFile targetFile
1927 -- If the removeFile succeeds and the renameFile fails
1928 -- then we've lost the atomic property.
1929 else throwIOIO err
1930 #else
1931 renameFile newFile targetFile
1932 #endif
1933 `Exception.onException` do hClose newHandle
1934 removeFileSafe newFile
1935 where
1936 template = targetName <.> "tmp"
1937 targetDir | null targetDir_ = "."
1938 | otherwise = targetDir_
1939 --TODO: remove this when takeDirectory/splitFileName is fixed
1940 -- to always return a valid dir
1941 (targetDir_,targetName) = splitFileName targetFile
1942
1943 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1944 openNewFile dir template = do
1945 -- this was added to System.IO in 6.12.1
1946 -- we must use this version because the version below opens the file
1947 -- in binary mode.
1948 openTempFileWithDefaultPermissions dir template
1949
1950 -- | The function splits the given string to substrings
1951 -- using 'isSearchPathSeparator'.
1952 parseSearchPath :: String -> [FilePath]
1953 parseSearchPath path = split path
1954 where
1955 split :: String -> [String]
1956 split s =
1957 case rest' of
1958 [] -> [chunk]
1959 _:rest -> chunk : split rest
1960 where
1961 chunk =
1962 case chunk' of
1963 #ifdef mingw32_HOST_OS
1964 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1965 #endif
1966 _ -> chunk'
1967
1968 (chunk', rest') = break isSearchPathSeparator s
1969
1970 readUTF8File :: FilePath -> IO String
1971 readUTF8File file = do
1972 h <- openFile file ReadMode
1973 -- fix the encoding to UTF-8
1974 hSetEncoding h utf8
1975 hGetContents h
1976
1977 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1978 removeFileSafe :: FilePath -> IO ()
1979 removeFileSafe fn =
1980 removeFile fn `catchIO` \ e ->
1981 when (not $ isDoesNotExistError e) $ ioError e
1982
1983 absolutePath :: FilePath -> IO FilePath
1984 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory