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