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