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