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