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