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