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