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