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