Merge ../HEAD
[ghc.git] / utils / ghc-pkg / Main.hs
1 {-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
2 -----------------------------------------------------------------------------
3 --
4 -- (c) The University of Glasgow 2004-2009.
5 --
6 -- Package management tool
7 --
8 -----------------------------------------------------------------------------
9
10 module Main (main) where
11
12 import Version ( version, targetOS, targetARCH )
13 import Distribution.InstalledPackageInfo.Binary()
14 import qualified Distribution.Simple.PackageIndex as PackageIndex
15 import Distribution.ModuleName hiding (main)
16 import Distribution.InstalledPackageInfo
17 import Distribution.Compat.ReadP
18 import Distribution.ParseUtils
19 import Distribution.Package hiding (depends)
20 import Distribution.Text
21 import Distribution.Version
22 import System.FilePath as FilePath
23 import qualified System.FilePath.Posix as FilePath.Posix
24 import System.Cmd ( rawSystem )
25 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
26 getModificationTime )
27 import Text.Printf
28
29 import Prelude
30
31 import System.Console.GetOpt
32 import qualified Control.Exception as Exception
33 import Data.Maybe
34
35 import Data.Char ( isSpace, toLower )
36 import Control.Monad
37 import System.Directory ( doesDirectoryExist, getDirectoryContents,
38 doesFileExist, renameFile, removeFile,
39 getCurrentDirectory )
40 import System.Exit ( exitWith, ExitCode(..) )
41 import System.Environment ( getArgs, getProgName, getEnv )
42 import System.IO
43 import System.IO.Error
44 import Data.List
45 import Control.Concurrent
46
47 import qualified Data.ByteString.Lazy as B
48 import qualified Data.Binary as Bin
49 import qualified Data.Binary.Get as Bin
50
51 #if defined(mingw32_HOST_OS)
52 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
53 import Foreign
54 import Foreign.C
55 #endif
56
57 #ifdef mingw32_HOST_OS
58 import GHC.ConsoleHandler
59 #else
60 import System.Posix hiding (fdToHandle)
61 #endif
62
63 #if defined(GLOB)
64 import System.Process(runInteractiveCommand)
65 import qualified System.Info(os)
66 #endif
67
68 #if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
69 import System.Console.Terminfo as Terminfo
70 #endif
71
72 #ifdef mingw32_HOST_OS
73 # if defined(i386_HOST_ARCH)
74 # define WINDOWS_CCONV stdcall
75 # elif defined(x86_64_HOST_ARCH)
76 # define WINDOWS_CCONV ccall
77 # else
78 # error Unknown mingw32 arch
79 # endif
80 #endif
81
82 -- -----------------------------------------------------------------------------
83 -- Entry point
84
85 main :: IO ()
86 main = do
87 args <- getArgs
88
89 case getOpt Permute (flags ++ deprecFlags) args of
90 (cli,_,[]) | FlagHelp `elem` cli -> do
91 prog <- getProgramName
92 bye (usageInfo (usageHeader prog) flags)
93 (cli,_,[]) | FlagVersion `elem` cli ->
94 bye ourCopyright
95 (cli,nonopts,[]) ->
96 case getVerbosity Normal cli of
97 Right v -> runit v cli nonopts
98 Left err -> die err
99 (_,_,errors) -> do
100 prog <- getProgramName
101 die (concat errors ++ usageInfo (usageHeader prog) flags)
102
103 -- -----------------------------------------------------------------------------
104 -- Command-line syntax
105
106 data Flag
107 = FlagUser
108 | FlagGlobal
109 | FlagHelp
110 | FlagVersion
111 | FlagConfig FilePath
112 | FlagGlobalConfig FilePath
113 | FlagForce
114 | FlagForceFiles
115 | FlagAutoGHCiLibs
116 | FlagExpandEnvVars
117 | FlagExpandPkgroot
118 | FlagNoExpandPkgroot
119 | FlagSimpleOutput
120 | FlagNamesOnly
121 | FlagIgnoreCase
122 | FlagNoUserDb
123 | FlagVerbosity (Maybe String)
124 deriving Eq
125
126 flags :: [OptDescr Flag]
127 flags = [
128 Option [] ["user"] (NoArg FlagUser)
129 "use the current user's package database",
130 Option [] ["global"] (NoArg FlagGlobal)
131 "use the global package database",
132 Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")
133 "use the specified package database",
134 Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")
135 "use the specified package database (DEPRECATED)",
136 Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")
137 "location of the global package database",
138 Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
139 "never read the user package database",
140 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
141 "never read the user package database (DEPRECATED)",
142 Option [] ["force"] (NoArg FlagForce)
143 "ignore missing dependencies, directories, and libraries",
144 Option [] ["force-files"] (NoArg FlagForceFiles)
145 "ignore missing directories and libraries only",
146 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
147 "automatically build libs for GHCi (with register)",
148 Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
149 "expand environment variables (${name}-style) in input package descriptions",
150 Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
151 "expand ${pkgroot}-relative paths to absolute in output package descriptions",
152 Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
153 "preserve ${pkgroot}-relative paths in output package descriptions",
154 Option ['?'] ["help"] (NoArg FlagHelp)
155 "display this help and exit",
156 Option ['V'] ["version"] (NoArg FlagVersion)
157 "output version information and exit",
158 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
159 "print output in easy-to-parse format for some commands",
160 Option [] ["names-only"] (NoArg FlagNamesOnly)
161 "only print package names, not versions; can only be used with list --simple-output",
162 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
163 "ignore case for substring matching",
164 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
165 "verbosity level (0-2, default 1)"
166 ]
167
168 data Verbosity = Silent | Normal | Verbose
169 deriving (Show, Eq, Ord)
170
171 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
172 getVerbosity v [] = Right v
173 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
174 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
175 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
176 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
177 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
178 getVerbosity v (_ : fs) = getVerbosity v fs
179
180 deprecFlags :: [OptDescr Flag]
181 deprecFlags = [
182 -- put deprecated flags here
183 ]
184
185 ourCopyright :: String
186 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
187
188 usageHeader :: String -> String
189 usageHeader prog = substProg prog $
190 "Usage:\n" ++
191 " $p init {path}\n" ++
192 " Create and initialise a package database at the location {path}.\n" ++
193 " Packages can be registered in the new database using the register\n" ++
194 " command with --package-db={path}. To use the new database with GHC,\n" ++
195 " use GHC's -package-db flag.\n" ++
196 "\n" ++
197 " $p register {filename | -}\n" ++
198 " Register the package using the specified installed package\n" ++
199 " description. The syntax for the latter is given in the $p\n" ++
200 " documentation. The input file should be encoded in UTF-8.\n" ++
201 "\n" ++
202 " $p update {filename | -}\n" ++
203 " Register the package, overwriting any other package with the\n" ++
204 " same name. The input file should be encoded in UTF-8.\n" ++
205 "\n" ++
206 " $p unregister {pkg-id}\n" ++
207 " Unregister the specified package.\n" ++
208 "\n" ++
209 " $p expose {pkg-id}\n" ++
210 " Expose the specified package.\n" ++
211 "\n" ++
212 " $p hide {pkg-id}\n" ++
213 " Hide the specified package.\n" ++
214 "\n" ++
215 " $p trust {pkg-id}\n" ++
216 " Trust the specified package.\n" ++
217 "\n" ++
218 " $p distrust {pkg-id}\n" ++
219 " Distrust the specified package.\n" ++
220 "\n" ++
221 " $p list [pkg]\n" ++
222 " List registered packages in the global database, and also the\n" ++
223 " user database if --user is given. If a package name is given\n" ++
224 " all the registered versions will be listed in ascending order.\n" ++
225 " Accepts the --simple-output flag.\n" ++
226 "\n" ++
227 " $p dot\n" ++
228 " Generate a graph of the package dependencies in a form suitable\n" ++
229 " for input for the graphviz tools. For example, to generate a PDF" ++
230 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
231 "\n" ++
232 " $p find-module {module}\n" ++
233 " List registered packages exposing module {module} in the global\n" ++
234 " database, and also the user database if --user is given.\n" ++
235 " All the registered versions will be listed in ascending order.\n" ++
236 " Accepts the --simple-output flag.\n" ++
237 "\n" ++
238 " $p latest {pkg-id}\n" ++
239 " Prints the highest registered version of a package.\n" ++
240 "\n" ++
241 " $p check\n" ++
242 " Check the consistency of package depenencies and list broken packages.\n" ++
243 " Accepts the --simple-output flag.\n" ++
244 "\n" ++
245 " $p describe {pkg}\n" ++
246 " Give the registered description for the specified package. The\n" ++
247 " description is returned in precisely the syntax required by $p\n" ++
248 " register.\n" ++
249 "\n" ++
250 " $p field {pkg} {field}\n" ++
251 " Extract the specified field of the package description for the\n" ++
252 " specified package. Accepts comma-separated multiple fields.\n" ++
253 "\n" ++
254 " $p dump\n" ++
255 " Dump the registered description for every package. This is like\n" ++
256 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
257 " by tools that parse the results, rather than humans. The output is\n" ++
258 " always encoded in UTF-8, regardless of the current locale.\n" ++
259 "\n" ++
260 " $p recache\n" ++
261 " Regenerate the package database cache. This command should only be\n" ++
262 " necessary if you added a package to the database by dropping a file\n" ++
263 " into the database directory manually. By default, the global DB\n" ++
264 " is recached; to recache a different DB use --user or --package-db\n" ++
265 " as appropriate.\n" ++
266 "\n" ++
267 " Substring matching is supported for {module} in find-module and\n" ++
268 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
269 " open substring ends (prefix*, *suffix, *infix*).\n" ++
270 "\n" ++
271 " When asked to modify a database (register, unregister, update,\n"++
272 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
273 " default. Specifying --user causes it to act on the user database,\n"++
274 " or --package-db can be used to act on another database\n"++
275 " entirely. When multiple of these options are given, the rightmost\n"++
276 " one is used as the database to act upon.\n"++
277 "\n"++
278 " Commands that query the package database (list, tree, latest, describe,\n"++
279 " field) operate on the list of databases specified by the flags\n"++
280 " --user, --global, and --package-db. If none of these flags are\n"++
281 " given, the default is --global --user.\n"++
282 "\n" ++
283 " The following optional flags are also accepted:\n"
284
285 substProg :: String -> String -> String
286 substProg _ [] = []
287 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
288 substProg prog (c:xs) = c : substProg prog xs
289
290 -- -----------------------------------------------------------------------------
291 -- Do the business
292
293 data Force = NoForce | ForceFiles | ForceAll | CannotForce
294 deriving (Eq,Ord)
295
296 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
297
298 runit :: Verbosity -> [Flag] -> [String] -> IO ()
299 runit verbosity cli nonopts = do
300 installSignalHandlers -- catch ^C and clean up
301 prog <- getProgramName
302 let
303 force
304 | FlagForce `elem` cli = ForceAll
305 | FlagForceFiles `elem` cli = ForceFiles
306 | otherwise = NoForce
307 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
308 expand_env_vars= FlagExpandEnvVars `elem` cli
309 mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
310 where accumExpandPkgroot _ FlagExpandPkgroot = Just True
311 accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
312 accumExpandPkgroot x _ = x
313
314 splitFields fields = unfoldr splitComma (',':fields)
315 where splitComma "" = Nothing
316 splitComma fs = Just $ break (==',') (tail fs)
317
318 substringCheck :: String -> Maybe (String -> Bool)
319 substringCheck "" = Nothing
320 substringCheck "*" = Just (const True)
321 substringCheck [_] = Nothing
322 substringCheck (h:t) =
323 case (h, init t, last t) of
324 ('*',s,'*') -> Just (isInfixOf (f s) . f)
325 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
326 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
327 _ -> Nothing
328 where f | FlagIgnoreCase `elem` cli = map toLower
329 | otherwise = id
330 #if defined(GLOB)
331 glob x | System.Info.os=="mingw32" = do
332 -- glob echoes its argument, after win32 filename globbing
333 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
334 txt <- hGetContents o
335 return (read txt)
336 glob x | otherwise = return [x]
337 #endif
338 --
339 -- first, parse the command
340 case nonopts of
341 #if defined(GLOB)
342 -- dummy command to demonstrate usage and permit testing
343 -- without messing things up; use glob to selectively enable
344 -- windows filename globbing for file parameters
345 -- register, update, FlagGlobalConfig, FlagConfig; others?
346 ["glob", filename] -> do
347 print filename
348 glob filename >>= print
349 #endif
350 ["init", filename] ->
351 initPackageDB filename verbosity cli
352 ["register", filename] ->
353 registerPackage filename verbosity cli
354 auto_ghci_libs expand_env_vars False force
355 ["update", filename] ->
356 registerPackage filename verbosity cli
357 auto_ghci_libs expand_env_vars True force
358 ["unregister", pkgid_str] -> do
359 pkgid <- readGlobPkgId pkgid_str
360 unregisterPackage pkgid verbosity cli force
361 ["expose", pkgid_str] -> do
362 pkgid <- readGlobPkgId pkgid_str
363 exposePackage pkgid verbosity cli force
364 ["hide", pkgid_str] -> do
365 pkgid <- readGlobPkgId pkgid_str
366 hidePackage pkgid verbosity cli force
367 ["trust", pkgid_str] -> do
368 pkgid <- readGlobPkgId pkgid_str
369 trustPackage pkgid verbosity cli force
370 ["distrust", pkgid_str] -> do
371 pkgid <- readGlobPkgId pkgid_str
372 distrustPackage pkgid verbosity cli force
373 ["list"] -> do
374 listPackages verbosity cli Nothing Nothing
375 ["list", pkgid_str] ->
376 case substringCheck pkgid_str of
377 Nothing -> do pkgid <- readGlobPkgId pkgid_str
378 listPackages verbosity cli (Just (Id pkgid)) Nothing
379 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
380 ["dot"] -> do
381 showPackageDot verbosity cli
382 ["find-module", moduleName] -> do
383 let match = maybe (==moduleName) id (substringCheck moduleName)
384 listPackages verbosity cli Nothing (Just match)
385 ["latest", pkgid_str] -> do
386 pkgid <- readGlobPkgId pkgid_str
387 latestPackage verbosity cli pkgid
388 ["describe", pkgid_str] -> do
389 pkgarg <- case substringCheck pkgid_str of
390 Nothing -> liftM Id (readGlobPkgId pkgid_str)
391 Just m -> return (Substring pkgid_str m)
392 describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
393
394 ["field", pkgid_str, fields] -> do
395 pkgarg <- case substringCheck pkgid_str of
396 Nothing -> liftM Id (readGlobPkgId pkgid_str)
397 Just m -> return (Substring pkgid_str m)
398 describeField verbosity cli pkgarg
399 (splitFields fields) (fromMaybe True mexpand_pkgroot)
400
401 ["check"] -> do
402 checkConsistency verbosity cli
403
404 ["dump"] -> do
405 dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
406
407 ["recache"] -> do
408 recache verbosity cli
409
410 [] -> do
411 die ("missing command\n" ++
412 usageInfo (usageHeader prog) flags)
413 (_cmd:_) -> do
414 die ("command-line syntax error\n" ++
415 usageInfo (usageHeader prog) flags)
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 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
989 where
990 pp_pkgs = map pp_pkg pkg_confs
991 pp_pkg p
992 | sourcePackageId p `elem` broken = printf "{%s}" doc
993 | exposed p = doc
994 | otherwise = printf "(%s)" doc
995 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
996 | otherwise = pkg
997 where
998 InstalledPackageId ipid = installedPackageId p
999 pkg = display (sourcePackageId p)
1000
1001 show_simple = simplePackageList my_flags . allPackagesInStack
1002
1003 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
1004 prog <- getProgramName
1005 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
1006
1007 if simple_output then show_simple stack else do
1008
1009 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
1010 mapM_ show_normal stack
1011 #else
1012 let
1013 show_colour withF db =
1014 mconcat $ map (<#> termText "\n") $
1015 (termText (location db) :
1016 map (termText " " <#>) (map pp_pkg (packages db)))
1017 where
1018 pp_pkg p
1019 | sourcePackageId p `elem` broken = withF Red doc
1020 | exposed p = doc
1021 | otherwise = withF Blue doc
1022 where doc | verbosity >= Verbose
1023 = termText (printf "%s (%s)" pkg ipid)
1024 | otherwise
1025 = termText pkg
1026 where
1027 InstalledPackageId ipid = installedPackageId p
1028 pkg = display (sourcePackageId p)
1029
1030 is_tty <- hIsTerminalDevice stdout
1031 if not is_tty
1032 then mapM_ show_normal stack
1033 else do tty <- Terminfo.setupTermFromEnv
1034 case Terminfo.getCapability tty withForegroundColor of
1035 Nothing -> mapM_ show_normal stack
1036 Just w -> runTermOutput tty $ mconcat $
1037 map (show_colour w) stack
1038 #endif
1039
1040 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1041 simplePackageList my_flags pkgs = do
1042 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1043 else display
1044 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
1045 when (not (null pkgs)) $
1046 hPutStrLn stdout $ concat $ intersperse " " strs
1047
1048 showPackageDot :: Verbosity -> [Flag] -> IO ()
1049 showPackageDot verbosity myflags = do
1050 (_, _, flag_db_stack) <-
1051 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
1052
1053 let all_pkgs = allPackagesInStack flag_db_stack
1054 ipix = PackageIndex.fromList all_pkgs
1055
1056 putStrLn "digraph {"
1057 let quote s = '"':s ++ "\""
1058 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1059 | p <- all_pkgs,
1060 let from = display (sourcePackageId p),
1061 depid <- depends p,
1062 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1063 let to = display (sourcePackageId dep)
1064 ]
1065 putStrLn "}"
1066
1067 -- -----------------------------------------------------------------------------
1068 -- Prints the highest (hidden or exposed) version of a package
1069
1070 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1071 latestPackage verbosity my_flags pkgid = do
1072 (_, _, flag_db_stack) <-
1073 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1074
1075 ps <- findPackages flag_db_stack (Id pkgid)
1076 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
1077 where
1078 show_pkg [] = die "no matches"
1079 show_pkg pids = hPutStrLn stdout (display (last pids))
1080
1081 -- -----------------------------------------------------------------------------
1082 -- Describe
1083
1084 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1085 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1086 (_, _, flag_db_stack) <-
1087 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1088 dbs <- findPackagesByDB flag_db_stack pkgarg
1089 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1090 | (db, pkgs) <- dbs, pkg <- pkgs ]
1091
1092 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1093 dumpPackages verbosity my_flags expand_pkgroot = do
1094 (_, _, flag_db_stack) <-
1095 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1096 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1097 | db <- flag_db_stack, pkg <- packages db ]
1098
1099 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1100 doDump expand_pkgroot pkgs = do
1101 -- fix the encoding to UTF-8, since this is an interchange format
1102 hSetEncoding stdout utf8
1103 putStrLn $
1104 intercalate "---\n"
1105 [ if expand_pkgroot
1106 then showInstalledPackageInfo pkg
1107 else showInstalledPackageInfo pkg ++ pkgrootField
1108 | (pkg, pkgloc) <- pkgs
1109 , let pkgroot = takeDirectory pkgloc
1110 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
1111
1112 -- PackageId is can have globVersion for the version
1113 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1114 findPackages db_stack pkgarg
1115 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1116
1117 findPackagesByDB :: PackageDBStack -> PackageArg
1118 -> IO [(PackageDB, [InstalledPackageInfo])]
1119 findPackagesByDB db_stack pkgarg
1120 = case [ (db, matched)
1121 | db <- db_stack,
1122 let matched = filter (pkgarg `matchesPkg`) (packages db),
1123 not (null matched) ] of
1124 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1125 ps -> return ps
1126 where
1127 pkg_msg (Id pkgid) = display pkgid
1128 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1129
1130 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1131 pid `matches` pid'
1132 = (pkgName pid == pkgName pid')
1133 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1134
1135 realVersion :: PackageIdentifier -> Bool
1136 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1137 -- when versionBranch == [], this is a glob
1138
1139 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1140 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1141 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1142
1143 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
1144 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
1145
1146 -- -----------------------------------------------------------------------------
1147 -- Field
1148
1149 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1150 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1151 (_, _, flag_db_stack) <-
1152 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1153 fns <- toFields fields
1154 ps <- findPackages flag_db_stack pkgarg
1155 mapM_ (selectFields fns) ps
1156 where toFields [] = return []
1157 toFields (f:fs) = case toField f of
1158 Nothing -> die ("unknown field: " ++ f)
1159 Just fn -> do fns <- toFields fs
1160 return (fn:fns)
1161 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
1162
1163 toField :: String -> Maybe (InstalledPackageInfo -> String)
1164 -- backwards compatibility:
1165 toField "import_dirs" = Just $ strList . importDirs
1166 toField "source_dirs" = Just $ strList . importDirs
1167 toField "library_dirs" = Just $ strList . libraryDirs
1168 toField "hs_libraries" = Just $ strList . hsLibraries
1169 toField "extra_libraries" = Just $ strList . extraLibraries
1170 toField "include_dirs" = Just $ strList . includeDirs
1171 toField "c_includes" = Just $ strList . includes
1172 toField "package_deps" = Just $ strList . map display. depends
1173 toField "extra_cc_opts" = Just $ strList . ccOptions
1174 toField "extra_ld_opts" = Just $ strList . ldOptions
1175 toField "framework_dirs" = Just $ strList . frameworkDirs
1176 toField "extra_frameworks"= Just $ strList . frameworks
1177 toField s = showInstalledPackageInfoField s
1178
1179 strList :: [String] -> String
1180 strList = show
1181
1182
1183 -- -----------------------------------------------------------------------------
1184 -- Check: Check consistency of installed packages
1185
1186 checkConsistency :: Verbosity -> [Flag] -> IO ()
1187 checkConsistency verbosity my_flags = do
1188 (db_stack, _, _) <-
1189 getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
1190 -- check behaves like modify for the purposes of deciding which
1191 -- databases to use, because ordering is important.
1192
1193 let simple_output = FlagSimpleOutput `elem` my_flags
1194
1195 let pkgs = allPackagesInStack db_stack
1196
1197 checkPackage p = do
1198 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True
1199 if null es
1200 then do when (not simple_output) $ do
1201 _ <- reportValidateErrors [] ws "" Nothing
1202 return ()
1203 return []
1204 else do
1205 when (not simple_output) $ do
1206 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1207 _ <- reportValidateErrors es ws " " Nothing
1208 return ()
1209 return [p]
1210
1211 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1212
1213 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1214 where not_in p = sourcePackageId p `notElem` all_ps
1215 all_ps = map sourcePackageId pkgs1
1216
1217 let not_broken_pkgs = filterOut broken_pkgs pkgs
1218 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1219 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1220
1221 when (not (null all_broken_pkgs)) $ do
1222 if simple_output
1223 then simplePackageList my_flags all_broken_pkgs
1224 else do
1225 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1226 "listed above, or because they depend on a broken package.")
1227 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1228
1229 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1230
1231
1232 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1233 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1234 closure pkgs db_stack = go pkgs db_stack
1235 where
1236 go avail not_avail =
1237 case partition (depsAvailable avail) not_avail of
1238 ([], not_avail') -> (avail, not_avail')
1239 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1240
1241 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1242 -> Bool
1243 depsAvailable pkgs_ok pkg = null dangling
1244 where dangling = filter (`notElem` pids) (depends pkg)
1245 pids = map installedPackageId pkgs_ok
1246
1247 -- we want mutually recursive groups of package to show up
1248 -- as broken. (#1750)
1249
1250 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1251 brokenPackages pkgs = snd (closure [] pkgs)
1252
1253 -- -----------------------------------------------------------------------------
1254 -- Manipulating package.conf files
1255
1256 type InstalledPackageInfoString = InstalledPackageInfo_ String
1257
1258 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1259 convertPackageInfoOut
1260 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1261 hiddenModules = h })) =
1262 pkgconf{ exposedModules = map display e,
1263 hiddenModules = map display h }
1264
1265 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1266 convertPackageInfoIn
1267 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1268 hiddenModules = h })) =
1269 pkgconf{ exposedModules = map convert e,
1270 hiddenModules = map convert h }
1271 where convert = fromJust . simpleParse
1272
1273 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1274 writeNewConfig verbosity filename ipis = do
1275 when (verbosity >= Normal) $
1276 info "Writing new package config file... "
1277 createDirectoryIfMissing True $ takeDirectory filename
1278 let shown = concat $ intersperse ",\n "
1279 $ map (show . convertPackageInfoOut) ipis
1280 fileContents = "[" ++ shown ++ "\n]"
1281 writeFileUtf8Atomic filename fileContents
1282 `catchIO` \e ->
1283 if isPermissionError e
1284 then die (filename ++ ": you don't have permission to modify this file")
1285 else ioError e
1286 when (verbosity >= Normal) $
1287 infoLn "done."
1288
1289 -----------------------------------------------------------------------------
1290 -- Sanity-check a new package config, and automatically build GHCi libs
1291 -- if requested.
1292
1293 type ValidateError = (Force,String)
1294 type ValidateWarning = String
1295
1296 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1297
1298 instance Monad Validate where
1299 return a = V $ return (a, [], [])
1300 m >>= k = V $ do
1301 (a, es, ws) <- runValidate m
1302 (b, es', ws') <- runValidate (k a)
1303 return (b,es++es',ws++ws')
1304
1305 verror :: Force -> String -> Validate ()
1306 verror f s = V (return ((),[(f,s)],[]))
1307
1308 vwarn :: String -> Validate ()
1309 vwarn s = V (return ((),[],["Warning: " ++ s]))
1310
1311 liftIO :: IO a -> Validate a
1312 liftIO k = V (k >>= \a -> return (a,[],[]))
1313
1314 -- returns False if we should die
1315 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1316 -> String -> Maybe Force -> IO Bool
1317 reportValidateErrors es ws prefix mb_force = do
1318 mapM_ (warn . (prefix++)) ws
1319 oks <- mapM report es
1320 return (and oks)
1321 where
1322 report (f,s)
1323 | Just force <- mb_force
1324 = if (force >= f)
1325 then do reportError (prefix ++ s ++ " (ignoring)")
1326 return True
1327 else if f < CannotForce
1328 then do reportError (prefix ++ s ++ " (use --force to override)")
1329 return False
1330 else do reportError err
1331 return False
1332 | otherwise = do reportError err
1333 return False
1334 where
1335 err = prefix ++ s
1336
1337 validatePackageConfig :: InstalledPackageInfo
1338 -> Verbosity
1339 -> PackageDBStack
1340 -> Bool -- auto-ghc-libs
1341 -> Bool -- update, or check
1342 -> Force
1343 -> IO ()
1344 validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do
1345 (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update
1346 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1347 when (not ok) $ exitWith (ExitFailure 1)
1348
1349 checkPackageConfig :: InstalledPackageInfo
1350 -> Verbosity
1351 -> PackageDBStack
1352 -> Bool -- auto-ghc-libs
1353 -> Bool -- update, or check
1354 -> Validate ()
1355 checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do
1356 checkInstalledPackageId pkg db_stack update
1357 checkPackageId pkg
1358 checkDuplicates db_stack pkg update
1359 mapM_ (checkDep db_stack) (depends pkg)
1360 checkDuplicateDepends (depends pkg)
1361 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1362 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1363 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1364 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1365 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1366 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1367 checkModules pkg
1368 mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1369 -- ToDo: check these somehow?
1370 -- extra_libraries :: [String],
1371 -- c_includes :: [String],
1372
1373 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1374 -> Validate ()
1375 checkInstalledPackageId ipi db_stack update = do
1376 let ipid@(InstalledPackageId str) = installedPackageId ipi
1377 when (null str) $ verror CannotForce "missing id field"
1378 let dups = [ p | p <- allPackagesInStack db_stack,
1379 installedPackageId p == ipid ]
1380 when (not update && not (null dups)) $
1381 verror CannotForce $
1382 "package(s) with this id already exist: " ++
1383 unwords (map (display.packageId) dups)
1384
1385 -- When the package name and version are put together, sometimes we can
1386 -- end up with a package id that cannot be parsed. This will lead to
1387 -- difficulties when the user wants to refer to the package later, so
1388 -- we check that the package id can be parsed properly here.
1389 checkPackageId :: InstalledPackageInfo -> Validate ()
1390 checkPackageId ipi =
1391 let str = display (sourcePackageId ipi) in
1392 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1393 [_] -> return ()
1394 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1395 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1396
1397 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1398 checkDuplicates db_stack pkg update = do
1399 let
1400 pkgid = sourcePackageId pkg
1401 pkgs = packages (head db_stack)
1402 --
1403 -- Check whether this package id already exists in this DB
1404 --
1405 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1406 verror CannotForce $
1407 "package " ++ display pkgid ++ " is already installed"
1408
1409 let
1410 uncasep = map toLower . display
1411 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1412
1413 when (not update && not (null dups)) $ verror ForceAll $
1414 "Package names may be treated case-insensitively in the future.\n"++
1415 "Package " ++ display pkgid ++
1416 " overlaps with: " ++ unwords (map display dups)
1417
1418 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1419 checkDir = checkPath False True
1420 checkFile = checkPath False False
1421 checkDirURL = checkPath True True
1422
1423 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1424 checkPath url_ok is_dir warn_only thisfield d
1425 | url_ok && ("http://" `isPrefixOf` d
1426 || "https://" `isPrefixOf` d) = return ()
1427
1428 | url_ok
1429 , Just d' <- stripPrefix "file://" d
1430 = checkPath False is_dir warn_only thisfield d'
1431
1432 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1433 -- variables having been expanded already, see mungePackagePaths.
1434
1435 | isRelative d = verror ForceFiles $
1436 thisfield ++ ": " ++ d ++ " is a relative path which "
1437 ++ "makes no sense (as there is nothing for it to be "
1438 ++ "relative to). You can make paths relative to the "
1439 ++ "package database itself by using ${pkgroot}."
1440 -- relative paths don't make any sense; #4134
1441 | otherwise = do
1442 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1443 when (not there) $
1444 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1445 ++ if is_dir then "directory" else "file"
1446 in
1447 if warn_only
1448 then vwarn msg
1449 else verror ForceFiles msg
1450
1451 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1452 checkDep db_stack pkgid
1453 | pkgid `elem` pkgids = return ()
1454 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1455 ++ "\" doesn't exist")
1456 where
1457 all_pkgs = allPackagesInStack db_stack
1458 pkgids = map installedPackageId all_pkgs
1459
1460 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1461 checkDuplicateDepends deps
1462 | null dups = return ()
1463 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1464 unwords (map display dups))
1465 where
1466 dups = [ p | (p:_:_) <- group (sort deps) ]
1467
1468 checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
1469 checkHSLib verbosity dirs auto_ghci_libs lib = do
1470 let batch_lib_file = "lib" ++ lib ++ ".a"
1471 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1472 case m of
1473 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1474 " on library path")
1475 Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
1476
1477 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1478 doesFileExistOnPath file path = go path
1479 where go [] = return Nothing
1480 go (p:ps) = do b <- doesFileExistIn file p
1481 if b then return (Just p) else go ps
1482
1483 doesFileExistIn :: String -> String -> IO Bool
1484 doesFileExistIn lib d = doesFileExist (d </> lib)
1485
1486 checkModules :: InstalledPackageInfo -> Validate ()
1487 checkModules pkg = do
1488 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1489 where
1490 findModule modl = do
1491 -- there's no .hi file for GHC.Prim
1492 if modl == fromString "GHC.Prim" then return () else do
1493 let file = toFilePath modl <.> "hi"
1494 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1495 when (isNothing m) $
1496 verror ForceFiles ("file " ++ file ++ " is missing")
1497
1498 checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
1499 checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
1500 | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
1501 | otherwise = return ()
1502 where
1503 ghci_lib_file = lib <.> "o"
1504
1505 -- automatically build the GHCi version of a batch lib,
1506 -- using ld --whole-archive.
1507
1508 autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
1509 autoBuildGHCiLib verbosity dir batch_file ghci_file = do
1510 let ghci_lib_file = dir ++ '/':ghci_file
1511 batch_lib_file = dir ++ '/':batch_file
1512 when (verbosity >= Normal) $
1513 info ("building GHCi library " ++ ghci_lib_file ++ "...")
1514 #if defined(darwin_HOST_OS)
1515 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1516 #elif defined(mingw32_HOST_OS)
1517 execDir <- getLibDir
1518 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1519 #else
1520 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1521 #endif
1522 when (r /= ExitSuccess) $ exitWith r
1523 when (verbosity >= Normal) $
1524 infoLn (" done.")
1525
1526 -- -----------------------------------------------------------------------------
1527 -- Searching for modules
1528
1529 #if not_yet
1530
1531 findModules :: [FilePath] -> IO [String]
1532 findModules paths =
1533 mms <- mapM searchDir paths
1534 return (concat mms)
1535
1536 searchDir path prefix = do
1537 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1538 searchEntries path prefix fs
1539
1540 searchEntries path prefix [] = return []
1541 searchEntries path prefix (f:fs)
1542 | looks_like_a_module = do
1543 ms <- searchEntries path prefix fs
1544 return (prefix `joinModule` f : ms)
1545 | looks_like_a_component = do
1546 ms <- searchDir (path </> f) (prefix `joinModule` f)
1547 ms' <- searchEntries path prefix fs
1548 return (ms ++ ms')
1549 | otherwise
1550 searchEntries path prefix fs
1551
1552 where
1553 (base,suffix) = splitFileExt f
1554 looks_like_a_module =
1555 suffix `elem` haskell_suffixes &&
1556 all okInModuleName base
1557 looks_like_a_component =
1558 null suffix && all okInModuleName base
1559
1560 okInModuleName c
1561
1562 #endif
1563
1564 -- ---------------------------------------------------------------------------
1565 -- expanding environment variables in the package configuration
1566
1567 expandEnvVars :: String -> Force -> IO String
1568 expandEnvVars str0 force = go str0 ""
1569 where
1570 go "" acc = return $! reverse acc
1571 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1572 = do value <- lookupEnvVar var
1573 go rest (reverse value ++ acc)
1574 where close c = c == '}' || c == '\n' -- don't span newlines
1575 go (c:str) acc
1576 = go str (c:acc)
1577
1578 lookupEnvVar :: String -> IO String
1579 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1580 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1581 lookupEnvVar nm =
1582 catchIO (System.Environment.getEnv nm)
1583 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1584 show nm)
1585 return "")
1586
1587 -----------------------------------------------------------------------------
1588
1589 getProgramName :: IO String
1590 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1591 where str `withoutSuffix` suff
1592 | suff `isSuffixOf` str = take (length str - length suff) str
1593 | otherwise = str
1594
1595 bye :: String -> IO a
1596 bye s = putStr s >> exitWith ExitSuccess
1597
1598 die :: String -> IO a
1599 die = dieWith 1
1600
1601 dieWith :: Int -> String -> IO a
1602 dieWith ec s = do
1603 prog <- getProgramName
1604 reportError (prog ++ ": " ++ s)
1605 exitWith (ExitFailure ec)
1606
1607 dieOrForceAll :: Force -> String -> IO ()
1608 dieOrForceAll ForceAll s = ignoreError s
1609 dieOrForceAll _other s = dieForcible s
1610
1611 warn :: String -> IO ()
1612 warn = reportError
1613
1614 -- send info messages to stdout
1615 infoLn :: String -> IO ()
1616 infoLn = putStrLn
1617
1618 info :: String -> IO ()
1619 info = putStr
1620
1621 ignoreError :: String -> IO ()
1622 ignoreError s = reportError (s ++ " (ignoring)")
1623
1624 reportError :: String -> IO ()
1625 reportError s = do hFlush stdout; hPutStrLn stderr s
1626
1627 dieForcible :: String -> IO ()
1628 dieForcible s = die (s ++ " (use --force to override)")
1629
1630 my_head :: String -> [a] -> a
1631 my_head s [] = error s
1632 my_head _ (x : _) = x
1633
1634 -----------------------------------------
1635 -- Cut and pasted from ghc/compiler/main/SysTools
1636
1637 #if defined(mingw32_HOST_OS)
1638 subst :: Char -> Char -> String -> String
1639 subst a b ls = map (\ x -> if x == a then b else x) ls
1640
1641 unDosifyPath :: FilePath -> FilePath
1642 unDosifyPath xs = subst '\\' '/' xs
1643
1644 getLibDir :: IO (Maybe String)
1645 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1646
1647 -- (getExecDir cmd) returns the directory in which the current
1648 -- executable, which should be called 'cmd', is running
1649 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1650 -- you'll get "/a/b/c" back as the result
1651 getExecDir :: String -> IO (Maybe String)
1652 getExecDir cmd =
1653 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1654 where initN n = reverse . drop n . reverse
1655 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1656
1657 getExecPath :: IO (Maybe String)
1658 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1659 where
1660 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1661 ret <- c_GetModuleFileName nullPtr buf size
1662 case ret of
1663 0 -> return Nothing
1664 _ | ret < size -> fmap Just $ peekCWString buf
1665 | otherwise -> try_size (size * 2)
1666
1667 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1668 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1669 #else
1670 getLibDir :: IO (Maybe String)
1671 getLibDir = return Nothing
1672 #endif
1673
1674 -----------------------------------------
1675 -- Adapted from ghc/compiler/utils/Panic
1676
1677 installSignalHandlers :: IO ()
1678 installSignalHandlers = do
1679 threadid <- myThreadId
1680 let
1681 interrupt = Exception.throwTo threadid
1682 (Exception.ErrorCall "interrupted")
1683 --
1684 #if !defined(mingw32_HOST_OS)
1685 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1686 _ <- installHandler sigINT (Catch interrupt) Nothing
1687 return ()
1688 #else
1689 -- GHC 6.3+ has support for console events on Windows
1690 -- NOTE: running GHCi under a bash shell for some reason requires
1691 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1692 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1693 -- why --SDM 17/12/2004
1694 let sig_handler ControlC = interrupt
1695 sig_handler Break = interrupt
1696 sig_handler _ = return ()
1697
1698 _ <- installHandler (Catch sig_handler)
1699 return ()
1700 #endif
1701
1702 #if mingw32_HOST_OS || mingw32_TARGET_OS
1703 throwIOIO :: Exception.IOException -> IO a
1704 throwIOIO = Exception.throwIO
1705 #endif
1706
1707 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1708 catchIO = Exception.catch
1709
1710 catchError :: IO a -> (String -> IO a) -> IO a
1711 catchError io handler = io `Exception.catch` handler'
1712 where handler' (Exception.ErrorCall err) = handler err
1713
1714 tryIO :: IO a -> IO (Either Exception.IOException a)
1715 tryIO = Exception.try
1716
1717 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1718 writeBinaryFileAtomic targetFile obj =
1719 withFileAtomic targetFile $ \h -> do
1720 hSetBinaryMode h True
1721 B.hPutStr h (Bin.encode obj)
1722
1723 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1724 writeFileUtf8Atomic targetFile content =
1725 withFileAtomic targetFile $ \h -> do
1726 hSetEncoding h utf8
1727 hPutStr h content
1728
1729 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1730 -- to use text files here, rather than binary files.
1731 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1732 withFileAtomic targetFile write_content = do
1733 (newFile, newHandle) <- openNewFile targetDir template
1734 do write_content newHandle
1735 hClose newHandle
1736 #if mingw32_HOST_OS || mingw32_TARGET_OS
1737 renameFile newFile targetFile
1738 -- If the targetFile exists then renameFile will fail
1739 `catchIO` \err -> do
1740 exists <- doesFileExist targetFile
1741 if exists
1742 then do removeFileSafe targetFile
1743 -- Big fat hairy race condition
1744 renameFile newFile targetFile
1745 -- If the removeFile succeeds and the renameFile fails
1746 -- then we've lost the atomic property.
1747 else throwIOIO err
1748 #else
1749 renameFile newFile targetFile
1750 #endif
1751 `Exception.onException` do hClose newHandle
1752 removeFileSafe newFile
1753 where
1754 template = targetName <.> "tmp"
1755 targetDir | null targetDir_ = "."
1756 | otherwise = targetDir_
1757 --TODO: remove this when takeDirectory/splitFileName is fixed
1758 -- to always return a valid dir
1759 (targetDir_,targetName) = splitFileName targetFile
1760
1761 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1762 openNewFile dir template = do
1763 -- this was added to System.IO in 6.12.1
1764 -- we must use this version because the version below opens the file
1765 -- in binary mode.
1766 openTempFileWithDefaultPermissions dir template
1767
1768 -- | The function splits the given string to substrings
1769 -- using 'isSearchPathSeparator'.
1770 parseSearchPath :: String -> [FilePath]
1771 parseSearchPath path = split path
1772 where
1773 split :: String -> [String]
1774 split s =
1775 case rest' of
1776 [] -> [chunk]
1777 _:rest -> chunk : split rest
1778 where
1779 chunk =
1780 case chunk' of
1781 #ifdef mingw32_HOST_OS
1782 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1783 #endif
1784 _ -> chunk'
1785
1786 (chunk', rest') = break isSearchPathSeparator s
1787
1788 readUTF8File :: FilePath -> IO String
1789 readUTF8File file = do
1790 h <- openFile file ReadMode
1791 -- fix the encoding to UTF-8
1792 hSetEncoding h utf8
1793 hGetContents h
1794
1795 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1796 removeFileSafe :: FilePath -> IO ()
1797 removeFileSafe fn =
1798 removeFile fn `catchIO` \ e ->
1799 when (not $ isDoesNotExistError e) $ ioError e
1800
1801 absolutePath :: FilePath -> IO FilePath
1802 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory