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