Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[ghc.git] / utils / ghc-pkg / Main.hs
1 {-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
2 -----------------------------------------------------------------------------
3 --
4 -- (c) The University of Glasgow 2004-2009.
5 --
6 -- Package management tool
7 --
8 -----------------------------------------------------------------------------
9
10 module Main (main) where
11
12 import Version ( version, targetOS, targetARCH )
13 import Distribution.InstalledPackageInfo.Binary()
14 import qualified Distribution.Simple.PackageIndex as PackageIndex
15 import Distribution.ModuleName hiding (main)
16 import Distribution.InstalledPackageInfo
17 import Distribution.Compat.ReadP
18 import Distribution.ParseUtils
19 import Distribution.Package hiding (depends)
20 import Distribution.Text
21 import Distribution.Version
22 import System.FilePath as FilePath
23 import qualified System.FilePath.Posix as FilePath.Posix
24 import System.Cmd ( rawSystem )
25 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
26 getModificationTime )
27 import Text.Printf
28
29 import Prelude
30
31 import System.Console.GetOpt
32 import qualified Control.Exception as Exception
33 import Data.Maybe
34
35 import Data.Char ( isSpace, toLower )
36 import Control.Monad
37 import System.Directory ( doesDirectoryExist, getDirectoryContents,
38 doesFileExist, renameFile, removeFile,
39 getCurrentDirectory )
40 import System.Exit ( exitWith, ExitCode(..) )
41 import System.Environment ( getArgs, getProgName, getEnv )
42 import System.IO
43 import System.IO.Error
44 import Data.List
45 import Control.Concurrent
46
47 import qualified Data.ByteString.Lazy as B
48 import qualified Data.Binary as Bin
49 import qualified Data.Binary.Get as Bin
50
51 #if defined(mingw32_HOST_OS)
52 -- mingw32 needs these for getExecDir
53 import Foreign
54 import Foreign.C
55 #endif
56
57 #ifdef mingw32_HOST_OS
58 import GHC.ConsoleHandler
59 #else
60 import System.Posix hiding (fdToHandle)
61 #endif
62
63 #if defined(GLOB)
64 import System.Process(runInteractiveCommand)
65 import qualified System.Info(os)
66 #endif
67
68 #if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
69 import System.Console.Terminfo as Terminfo
70 #endif
71
72 #ifdef mingw32_HOST_OS
73 # if defined(i386_HOST_ARCH)
74 # define WINDOWS_CCONV stdcall
75 # elif defined(x86_64_HOST_ARCH)
76 # define WINDOWS_CCONV ccall
77 # else
78 # error Unknown mingw32 arch
79 # endif
80 #endif
81
82 -- -----------------------------------------------------------------------------
83 -- Entry point
84
85 main :: IO ()
86 main = do
87 args <- getArgs
88
89 case getOpt Permute (flags ++ deprecFlags) args of
90 (cli,_,[]) | FlagHelp `elem` cli -> do
91 prog <- getProgramName
92 bye (usageInfo (usageHeader prog) flags)
93 (cli,_,[]) | FlagVersion `elem` cli ->
94 bye ourCopyright
95 (cli,nonopts,[]) ->
96 case getVerbosity Normal cli of
97 Right v -> runit v cli nonopts
98 Left err -> die err
99 (_,_,errors) -> do
100 prog <- getProgramName
101 die (concat errors ++ 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
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
626 Right tcache
627 | tcache >= tdir -> do
628 when (verbosity > Normal) $
629 infoLn ("using cache: " ++ cache)
630 pkgs <- myReadBinPackageDB cache
631 let pkgs' = map convertPackageInfoIn pkgs
632 mkPackageDB pkgs'
633 | otherwise -> do
634 when (verbosity >= Normal) $ do
635 warn ("WARNING: cache is out of date: " ++ cache)
636 warn " use 'ghc-pkg recache' to fix."
637 ignore_cache
638 where
639 ignore_cache = do
640 let confs = filter (".conf" `isSuffixOf`) fs
641 pkgs <- mapM (parseSingletonPackageConf verbosity) $
642 map (path </>) confs
643 mkPackageDB pkgs
644 where
645 mkPackageDB pkgs = do
646 path_abs <- absolutePath path
647 return PackageDB {
648 location = path,
649 locationAbsolute = path_abs,
650 packages = pkgs
651 }
652
653 -- read the package.cache file strictly, to work around a problem with
654 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
655 -- after it has been completely read, leading to a sharing violation
656 -- later.
657 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
658 myReadBinPackageDB filepath = do
659 h <- openBinaryFile filepath ReadMode
660 sz <- hFileSize h
661 b <- B.hGet h (fromIntegral sz)
662 hClose h
663 return $ Bin.runGet Bin.get b
664
665 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
666 parseMultiPackageConf verbosity file = do
667 when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
668 str <- readUTF8File file
669 let pkgs = map convertPackageInfoIn $ read str
670 Exception.evaluate pkgs
671 `catchError` \e->
672 die ("error while parsing " ++ file ++ ": " ++ show e)
673
674 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
675 parseSingletonPackageConf verbosity file = do
676 when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
677 readUTF8File file >>= fmap fst . parsePackageInfo
678
679 cachefilename :: FilePath
680 cachefilename = "package.cache"
681
682 mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
683 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
684 db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
685 where
686 pkgroot = takeDirectory (locationAbsolute db)
687 -- It so happens that for both styles of package db ("package.conf"
688 -- files and "package.conf.d" dirs) the pkgroot is the parent directory
689 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
690
691 -- TODO: This code is duplicated in compiler/main/Packages.lhs
692 mungePackagePaths :: FilePath -> FilePath
693 -> InstalledPackageInfo -> InstalledPackageInfo
694 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
695 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
696 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
697 -- The "pkgroot" is the directory containing the package database.
698 --
699 -- Also perform a similar substitution for the older GHC-specific
700 -- "$topdir" variable. The "topdir" is the location of the ghc
701 -- installation (obtained from the -B option).
702 mungePackagePaths top_dir pkgroot pkg =
703 pkg {
704 importDirs = munge_paths (importDirs pkg),
705 includeDirs = munge_paths (includeDirs pkg),
706 libraryDirs = munge_paths (libraryDirs pkg),
707 frameworkDirs = munge_paths (frameworkDirs pkg),
708 haddockInterfaces = munge_paths (haddockInterfaces pkg),
709 -- haddock-html is allowed to be either a URL or a file
710 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
711 }
712 where
713 munge_paths = map munge_path
714 munge_urls = map munge_url
715
716 munge_path p
717 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
718 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
719 | otherwise = p
720
721 munge_url p
722 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
723 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
724 | otherwise = p
725
726 toUrlPath r p = "file:///"
727 -- URLs always use posix style '/' separators:
728 ++ FilePath.Posix.joinPath
729 (r : -- We need to drop a leading "/" or "\\"
730 -- if there is one:
731 dropWhile (all isPathSeparator)
732 (FilePath.splitDirectories p))
733
734 -- We could drop the separator here, and then use </> above. However,
735 -- by leaving it in and using ++ we keep the same path separator
736 -- rather than letting FilePath change it to use \ as the separator
737 stripVarPrefix var path = case stripPrefix var path of
738 Just [] -> Just []
739 Just cs@(c : _) | isPathSeparator c -> Just cs
740 _ -> Nothing
741
742
743 -- -----------------------------------------------------------------------------
744 -- Creating a new package DB
745
746 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
747 initPackageDB filename verbosity _flags = do
748 let eexist = die ("cannot create: " ++ filename ++ " already exists")
749 b1 <- doesFileExist filename
750 when b1 eexist
751 b2 <- doesDirectoryExist filename
752 when b2 eexist
753 filename_abs <- absolutePath filename
754 changeDB verbosity [] PackageDB {
755 location = filename, locationAbsolute = filename_abs,
756 packages = []
757 }
758
759 -- -----------------------------------------------------------------------------
760 -- Registering
761
762 registerPackage :: FilePath
763 -> Verbosity
764 -> [Flag]
765 -> Bool -- auto_ghci_libs
766 -> Bool -- expand_env_vars
767 -> Bool -- update
768 -> Force
769 -> IO ()
770 registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
771 (db_stack, Just to_modify, _flag_dbs) <-
772 getPkgDatabases verbosity True True False{-expand vars-} my_flags
773
774 let
775 db_to_operate_on = my_head "register" $
776 filter ((== to_modify).location) db_stack
777 --
778 when (auto_ghci_libs && verbosity >= Silent) $
779 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
780 --
781 s <-
782 case input of
783 "-" -> do
784 when (verbosity >= Normal) $
785 info "Reading package info from stdin ... "
786 -- fix the encoding to UTF-8, since this is an interchange format
787 hSetEncoding stdin utf8
788 getContents
789 f -> do
790 when (verbosity >= Normal) $
791 info ("Reading package info from " ++ show f ++ " ... ")
792 readUTF8File f
793
794 expanded <- if expand_env_vars then expandEnvVars s force
795 else return s
796
797 (pkg, ws) <- parsePackageInfo expanded
798 when (verbosity >= Normal) $
799 infoLn "done."
800
801 -- report any warnings from the parse phase
802 _ <- reportValidateErrors [] ws
803 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
804
805 -- validate the expanded pkg, but register the unexpanded
806 pkgroot <- absolutePath (takeDirectory to_modify)
807 let top_dir = takeDirectory (location (last db_stack))
808 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
809
810 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
811 -- truncate the stack for validation, because we don't allow
812 -- packages lower in the stack to refer to those higher up.
813 validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force
814 let
815 removes = [ RemovePackage p
816 | p <- packages db_to_operate_on,
817 sourcePackageId p == sourcePackageId pkg ]
818 --
819 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
820
821 parsePackageInfo
822 :: String
823 -> IO (InstalledPackageInfo, [ValidateWarning])
824 parsePackageInfo str =
825 case parseInstalledPackageInfo str of
826 ParseOk warnings ok -> return (ok, ws)
827 where
828 ws = [ msg | PWarning msg <- warnings
829 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
830 ParseFailed err -> case locatedErrorMsg err of
831 (Nothing, s) -> die s
832 (Just l, s) -> die (show l ++ ": " ++ s)
833
834 -- -----------------------------------------------------------------------------
835 -- Making changes to a package database
836
837 data DBOp = RemovePackage InstalledPackageInfo
838 | AddPackage InstalledPackageInfo
839 | ModifyPackage InstalledPackageInfo
840
841 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
842 changeDB verbosity cmds db = do
843 let db' = updateInternalDB db cmds
844 isfile <- doesFileExist (location db)
845 if isfile
846 then writeNewConfig verbosity (location db') (packages db')
847 else do
848 createDirectoryIfMissing True (location db)
849 changeDBDir verbosity cmds db'
850
851 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
852 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
853 where
854 do_cmd pkgs (RemovePackage p) =
855 filter ((/= installedPackageId p) . installedPackageId) pkgs
856 do_cmd pkgs (AddPackage p) = p : pkgs
857 do_cmd pkgs (ModifyPackage p) =
858 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
859
860
861 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
862 changeDBDir verbosity cmds db = do
863 mapM_ do_cmd cmds
864 updateDBCache verbosity db
865 where
866 do_cmd (RemovePackage p) = do
867 let file = location db </> display (installedPackageId p) <.> "conf"
868 when (verbosity > Normal) $ infoLn ("removing " ++ file)
869 removeFileSafe file
870 do_cmd (AddPackage p) = do
871 let file = location db </> display (installedPackageId p) <.> "conf"
872 when (verbosity > Normal) $ infoLn ("writing " ++ file)
873 writeFileUtf8Atomic file (showInstalledPackageInfo p)
874 do_cmd (ModifyPackage p) =
875 do_cmd (AddPackage p)
876
877 updateDBCache :: Verbosity -> PackageDB -> IO ()
878 updateDBCache verbosity db = do
879 let filename = location db </> cachefilename
880 when (verbosity > Normal) $
881 infoLn ("writing cache " ++ filename)
882 writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
883 `catchIO` \e ->
884 if isPermissionError e
885 then die (filename ++ ": you don't have permission to modify this file")
886 else ioError e
887
888 -- -----------------------------------------------------------------------------
889 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
890
891 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
892 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
893
894 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
895 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
896
897 trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
898 trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
899
900 distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
901 distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
902
903 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
904 unregisterPackage = modifyPackage RemovePackage
905
906 modifyPackage
907 :: (InstalledPackageInfo -> DBOp)
908 -> PackageIdentifier
909 -> Verbosity
910 -> [Flag]
911 -> Force
912 -> IO ()
913 modifyPackage fn pkgid verbosity my_flags force = do
914 (db_stack, Just _to_modify, _flag_dbs) <-
915 getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
916
917 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
918 let
919 db_name = location db
920 pkgs = packages db
921
922 pids = map sourcePackageId ps
923
924 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
925 new_db = updateInternalDB db cmds
926
927 old_broken = brokenPackages (allPackagesInStack db_stack)
928 rest_of_stack = filter ((/= db_name) . location) db_stack
929 new_stack = new_db : rest_of_stack
930 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
931 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
932 --
933 when (not (null newly_broken)) $
934 dieOrForceAll force ("unregistering " ++ display pkgid ++
935 " would break the following packages: "
936 ++ unwords (map display newly_broken))
937
938 changeDB verbosity cmds db
939
940 recache :: Verbosity -> [Flag] -> IO ()
941 recache verbosity my_flags = do
942 (db_stack, Just to_modify, _flag_dbs) <-
943 getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
944 let
945 db_to_operate_on = my_head "recache" $
946 filter ((== to_modify).location) db_stack
947 --
948 changeDB verbosity [] db_to_operate_on
949
950 -- -----------------------------------------------------------------------------
951 -- Listing packages
952
953 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
954 -> Maybe (String->Bool)
955 -> IO ()
956 listPackages verbosity my_flags mPackageName mModuleName = do
957 let simple_output = FlagSimpleOutput `elem` my_flags
958 (db_stack, _, flag_db_stack) <-
959 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
960
961 let db_stack_filtered -- if a package is given, filter out all other packages
962 | Just this <- mPackageName =
963 [ db{ packages = filter (this `matchesPkg`) (packages db) }
964 | db <- flag_db_stack ]
965 | Just match <- mModuleName = -- packages which expose mModuleName
966 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
967 | db <- flag_db_stack ]
968 | otherwise = flag_db_stack
969
970 db_stack_sorted
971 = [ db{ packages = sort_pkgs (packages db) }
972 | db <- db_stack_filtered ]
973 where sort_pkgs = sortBy cmpPkgIds
974 cmpPkgIds pkg1 pkg2 =
975 case pkgName p1 `compare` pkgName p2 of
976 LT -> LT
977 GT -> GT
978 EQ -> pkgVersion p1 `compare` pkgVersion p2
979 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
980
981 stack = reverse db_stack_sorted
982
983 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
984
985 pkg_map = allPackagesInStack db_stack
986 broken = map sourcePackageId (brokenPackages pkg_map)
987
988 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
989 do hPutStrLn stdout (db_name ++ ":")
990 if null pp_pkgs
991 then hPutStrLn stdout " (no packages)"
992 else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs)
993 where
994 pp_pkgs = map pp_pkg pkg_confs
995 pp_pkg p
996 | sourcePackageId p `elem` broken = printf "{%s}" doc
997 | exposed p = doc
998 | otherwise = printf "(%s)" doc
999 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
1000 | otherwise = pkg
1001 where
1002 InstalledPackageId ipid = installedPackageId p
1003 pkg = display (sourcePackageId p)
1004
1005 show_simple = simplePackageList my_flags . allPackagesInStack
1006
1007 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
1008 prog <- getProgramName
1009 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
1010
1011 if simple_output then show_simple stack else do
1012
1013 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
1014 mapM_ show_normal stack
1015 #else
1016 let
1017 show_colour withF db =
1018 mconcat $ map (<#> termText "\n") $
1019 (termText (location db) :
1020 map (termText " " <#>) (map pp_pkg (packages db)))
1021 where
1022 pp_pkg p
1023 | sourcePackageId p `elem` broken = withF Red doc
1024 | exposed p = doc
1025 | otherwise = withF Blue doc
1026 where doc | verbosity >= Verbose
1027 = termText (printf "%s (%s)" pkg ipid)
1028 | otherwise
1029 = termText pkg
1030 where
1031 InstalledPackageId ipid = installedPackageId p
1032 pkg = display (sourcePackageId p)
1033
1034 is_tty <- hIsTerminalDevice stdout
1035 if not is_tty
1036 then mapM_ show_normal stack
1037 else do tty <- Terminfo.setupTermFromEnv
1038 case Terminfo.getCapability tty withForegroundColor of
1039 Nothing -> mapM_ show_normal stack
1040 Just w -> runTermOutput tty $ mconcat $
1041 map (show_colour w) stack
1042 #endif
1043
1044 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1045 simplePackageList my_flags pkgs = do
1046 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1047 else display
1048 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
1049 when (not (null pkgs)) $
1050 hPutStrLn stdout $ concat $ intersperse " " strs
1051
1052 showPackageDot :: Verbosity -> [Flag] -> IO ()
1053 showPackageDot verbosity myflags = do
1054 (_, _, flag_db_stack) <-
1055 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
1056
1057 let all_pkgs = allPackagesInStack flag_db_stack
1058 ipix = PackageIndex.fromList all_pkgs
1059
1060 putStrLn "digraph {"
1061 let quote s = '"':s ++ "\""
1062 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1063 | p <- all_pkgs,
1064 let from = display (sourcePackageId p),
1065 depid <- depends p,
1066 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1067 let to = display (sourcePackageId dep)
1068 ]
1069 putStrLn "}"
1070
1071 -- -----------------------------------------------------------------------------
1072 -- Prints the highest (hidden or exposed) version of a package
1073
1074 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1075 latestPackage verbosity my_flags pkgid = do
1076 (_, _, flag_db_stack) <-
1077 getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
1078
1079 ps <- findPackages flag_db_stack (Id pkgid)
1080 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
1081 where
1082 show_pkg [] = die "no matches"
1083 show_pkg pids = hPutStrLn stdout (display (last pids))
1084
1085 -- -----------------------------------------------------------------------------
1086 -- Describe
1087
1088 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1089 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1090 (_, _, flag_db_stack) <-
1091 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1092 dbs <- findPackagesByDB flag_db_stack pkgarg
1093 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1094 | (db, pkgs) <- dbs, pkg <- pkgs ]
1095
1096 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1097 dumpPackages verbosity my_flags expand_pkgroot = do
1098 (_, _, flag_db_stack) <-
1099 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1100 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1101 | db <- flag_db_stack, pkg <- packages db ]
1102
1103 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1104 doDump expand_pkgroot pkgs = do
1105 -- fix the encoding to UTF-8, since this is an interchange format
1106 hSetEncoding stdout utf8
1107 putStrLn $
1108 intercalate "---\n"
1109 [ if expand_pkgroot
1110 then showInstalledPackageInfo pkg
1111 else showInstalledPackageInfo pkg ++ pkgrootField
1112 | (pkg, pkgloc) <- pkgs
1113 , let pkgroot = takeDirectory pkgloc
1114 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
1115
1116 -- PackageId is can have globVersion for the version
1117 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1118 findPackages db_stack pkgarg
1119 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1120
1121 findPackagesByDB :: PackageDBStack -> PackageArg
1122 -> IO [(PackageDB, [InstalledPackageInfo])]
1123 findPackagesByDB db_stack pkgarg
1124 = case [ (db, matched)
1125 | db <- db_stack,
1126 let matched = filter (pkgarg `matchesPkg`) (packages db),
1127 not (null matched) ] of
1128 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1129 ps -> return ps
1130 where
1131 pkg_msg (Id pkgid) = display pkgid
1132 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1133
1134 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1135 pid `matches` pid'
1136 = (pkgName pid == pkgName pid')
1137 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1138
1139 realVersion :: PackageIdentifier -> Bool
1140 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1141 -- when versionBranch == [], this is a glob
1142
1143 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1144 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1145 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1146
1147 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
1148 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
1149
1150 -- -----------------------------------------------------------------------------
1151 -- Field
1152
1153 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1154 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1155 (_, _, flag_db_stack) <-
1156 getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
1157 fns <- toFields fields
1158 ps <- findPackages flag_db_stack pkgarg
1159 mapM_ (selectFields fns) ps
1160 where toFields [] = return []
1161 toFields (f:fs) = case toField f of
1162 Nothing -> die ("unknown field: " ++ f)
1163 Just fn -> do fns <- toFields fs
1164 return (fn:fns)
1165 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
1166
1167 toField :: String -> Maybe (InstalledPackageInfo -> String)
1168 -- backwards compatibility:
1169 toField "import_dirs" = Just $ strList . importDirs
1170 toField "source_dirs" = Just $ strList . importDirs
1171 toField "library_dirs" = Just $ strList . libraryDirs
1172 toField "hs_libraries" = Just $ strList . hsLibraries
1173 toField "extra_libraries" = Just $ strList . extraLibraries
1174 toField "include_dirs" = Just $ strList . includeDirs
1175 toField "c_includes" = Just $ strList . includes
1176 toField "package_deps" = Just $ strList . map display. depends
1177 toField "extra_cc_opts" = Just $ strList . ccOptions
1178 toField "extra_ld_opts" = Just $ strList . ldOptions
1179 toField "framework_dirs" = Just $ strList . frameworkDirs
1180 toField "extra_frameworks"= Just $ strList . frameworks
1181 toField s = showInstalledPackageInfoField s
1182
1183 strList :: [String] -> String
1184 strList = show
1185
1186
1187 -- -----------------------------------------------------------------------------
1188 -- Check: Check consistency of installed packages
1189
1190 checkConsistency :: Verbosity -> [Flag] -> IO ()
1191 checkConsistency verbosity my_flags = do
1192 (db_stack, _, _) <-
1193 getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
1194 -- check behaves like modify for the purposes of deciding which
1195 -- databases to use, because ordering is important.
1196
1197 let simple_output = FlagSimpleOutput `elem` my_flags
1198
1199 let pkgs = allPackagesInStack db_stack
1200
1201 checkPackage p = do
1202 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True
1203 if null es
1204 then do when (not simple_output) $ do
1205 _ <- reportValidateErrors [] ws "" Nothing
1206 return ()
1207 return []
1208 else do
1209 when (not simple_output) $ do
1210 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1211 _ <- reportValidateErrors es ws " " Nothing
1212 return ()
1213 return [p]
1214
1215 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1216
1217 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1218 where not_in p = sourcePackageId p `notElem` all_ps
1219 all_ps = map sourcePackageId pkgs1
1220
1221 let not_broken_pkgs = filterOut broken_pkgs pkgs
1222 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1223 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1224
1225 when (not (null all_broken_pkgs)) $ do
1226 if simple_output
1227 then simplePackageList my_flags all_broken_pkgs
1228 else do
1229 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1230 "listed above, or because they depend on a broken package.")
1231 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1232
1233 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1234
1235
1236 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1237 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1238 closure pkgs db_stack = go pkgs db_stack
1239 where
1240 go avail not_avail =
1241 case partition (depsAvailable avail) not_avail of
1242 ([], not_avail') -> (avail, not_avail')
1243 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1244
1245 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1246 -> Bool
1247 depsAvailable pkgs_ok pkg = null dangling
1248 where dangling = filter (`notElem` pids) (depends pkg)
1249 pids = map installedPackageId pkgs_ok
1250
1251 -- we want mutually recursive groups of package to show up
1252 -- as broken. (#1750)
1253
1254 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1255 brokenPackages pkgs = snd (closure [] pkgs)
1256
1257 -- -----------------------------------------------------------------------------
1258 -- Manipulating package.conf files
1259
1260 type InstalledPackageInfoString = InstalledPackageInfo_ String
1261
1262 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1263 convertPackageInfoOut
1264 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1265 hiddenModules = h })) =
1266 pkgconf{ exposedModules = map display e,
1267 hiddenModules = map display h }
1268
1269 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1270 convertPackageInfoIn
1271 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1272 hiddenModules = h })) =
1273 pkgconf{ exposedModules = map convert e,
1274 hiddenModules = map convert h }
1275 where convert = fromJust . simpleParse
1276
1277 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1278 writeNewConfig verbosity filename ipis = do
1279 when (verbosity >= Normal) $
1280 info "Writing new package config file... "
1281 createDirectoryIfMissing True $ takeDirectory filename
1282 let shown = concat $ intersperse ",\n "
1283 $ map (show . convertPackageInfoOut) ipis
1284 fileContents = "[" ++ shown ++ "\n]"
1285 writeFileUtf8Atomic filename fileContents
1286 `catchIO` \e ->
1287 if isPermissionError e
1288 then die (filename ++ ": you don't have permission to modify this file")
1289 else ioError e
1290 when (verbosity >= Normal) $
1291 infoLn "done."
1292
1293 -----------------------------------------------------------------------------
1294 -- Sanity-check a new package config, and automatically build GHCi libs
1295 -- if requested.
1296
1297 type ValidateError = (Force,String)
1298 type ValidateWarning = String
1299
1300 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1301
1302 instance Monad Validate where
1303 return a = V $ return (a, [], [])
1304 m >>= k = V $ do
1305 (a, es, ws) <- runValidate m
1306 (b, es', ws') <- runValidate (k a)
1307 return (b,es++es',ws++ws')
1308
1309 verror :: Force -> String -> Validate ()
1310 verror f s = V (return ((),[(f,s)],[]))
1311
1312 vwarn :: String -> Validate ()
1313 vwarn s = V (return ((),[],["Warning: " ++ s]))
1314
1315 liftIO :: IO a -> Validate a
1316 liftIO k = V (k >>= \a -> return (a,[],[]))
1317
1318 -- returns False if we should die
1319 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1320 -> String -> Maybe Force -> IO Bool
1321 reportValidateErrors es ws prefix mb_force = do
1322 mapM_ (warn . (prefix++)) ws
1323 oks <- mapM report es
1324 return (and oks)
1325 where
1326 report (f,s)
1327 | Just force <- mb_force
1328 = if (force >= f)
1329 then do reportError (prefix ++ s ++ " (ignoring)")
1330 return True
1331 else if f < CannotForce
1332 then do reportError (prefix ++ s ++ " (use --force to override)")
1333 return False
1334 else do reportError err
1335 return False
1336 | otherwise = do reportError err
1337 return False
1338 where
1339 err = prefix ++ s
1340
1341 validatePackageConfig :: InstalledPackageInfo
1342 -> Verbosity
1343 -> PackageDBStack
1344 -> Bool -- auto-ghc-libs
1345 -> Bool -- update, or check
1346 -> Force
1347 -> IO ()
1348 validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do
1349 (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update
1350 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1351 when (not ok) $ exitWith (ExitFailure 1)
1352
1353 checkPackageConfig :: InstalledPackageInfo
1354 -> Verbosity
1355 -> PackageDBStack
1356 -> Bool -- auto-ghc-libs
1357 -> Bool -- update, or check
1358 -> Validate ()
1359 checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do
1360 checkInstalledPackageId pkg db_stack update
1361 checkPackageId pkg
1362 checkDuplicates db_stack pkg update
1363 mapM_ (checkDep db_stack) (depends pkg)
1364 checkDuplicateDepends (depends pkg)
1365 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1366 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1367 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1368 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1369 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1370 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1371 checkModules pkg
1372 mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1373 -- ToDo: check these somehow?
1374 -- extra_libraries :: [String],
1375 -- c_includes :: [String],
1376
1377 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1378 -> Validate ()
1379 checkInstalledPackageId ipi db_stack update = do
1380 let ipid@(InstalledPackageId str) = installedPackageId ipi
1381 when (null str) $ verror CannotForce "missing id field"
1382 let dups = [ p | p <- allPackagesInStack db_stack,
1383 installedPackageId p == ipid ]
1384 when (not update && not (null dups)) $
1385 verror CannotForce $
1386 "package(s) with this id already exist: " ++
1387 unwords (map (display.packageId) dups)
1388
1389 -- When the package name and version are put together, sometimes we can
1390 -- end up with a package id that cannot be parsed. This will lead to
1391 -- difficulties when the user wants to refer to the package later, so
1392 -- we check that the package id can be parsed properly here.
1393 checkPackageId :: InstalledPackageInfo -> Validate ()
1394 checkPackageId ipi =
1395 let str = display (sourcePackageId ipi) in
1396 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1397 [_] -> return ()
1398 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1399 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1400
1401 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1402 checkDuplicates db_stack pkg update = do
1403 let
1404 pkgid = sourcePackageId pkg
1405 pkgs = packages (head db_stack)
1406 --
1407 -- Check whether this package id already exists in this DB
1408 --
1409 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1410 verror CannotForce $
1411 "package " ++ display pkgid ++ " is already installed"
1412
1413 let
1414 uncasep = map toLower . display
1415 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1416
1417 when (not update && not (null dups)) $ verror ForceAll $
1418 "Package names may be treated case-insensitively in the future.\n"++
1419 "Package " ++ display pkgid ++
1420 " overlaps with: " ++ unwords (map display dups)
1421
1422 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1423 checkDir = checkPath False True
1424 checkFile = checkPath False False
1425 checkDirURL = checkPath True True
1426
1427 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1428 checkPath url_ok is_dir warn_only thisfield d
1429 | url_ok && ("http://" `isPrefixOf` d
1430 || "https://" `isPrefixOf` d) = return ()
1431
1432 | url_ok
1433 , Just d' <- stripPrefix "file://" d
1434 = checkPath False is_dir warn_only thisfield d'
1435
1436 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1437 -- variables having been expanded already, see mungePackagePaths.
1438
1439 | isRelative d = verror ForceFiles $
1440 thisfield ++ ": " ++ d ++ " is a relative path which "
1441 ++ "makes no sense (as there is nothing for it to be "
1442 ++ "relative to). You can make paths relative to the "
1443 ++ "package database itself by using ${pkgroot}."
1444 -- relative paths don't make any sense; #4134
1445 | otherwise = do
1446 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1447 when (not there) $
1448 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1449 ++ if is_dir then "directory" else "file"
1450 in
1451 if warn_only
1452 then vwarn msg
1453 else verror ForceFiles msg
1454
1455 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1456 checkDep db_stack pkgid
1457 | pkgid `elem` pkgids = return ()
1458 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1459 ++ "\" doesn't exist")
1460 where
1461 all_pkgs = allPackagesInStack db_stack
1462 pkgids = map installedPackageId all_pkgs
1463
1464 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1465 checkDuplicateDepends deps
1466 | null dups = return ()
1467 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1468 unwords (map display dups))
1469 where
1470 dups = [ p | (p:_:_) <- group (sort deps) ]
1471
1472 checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
1473 checkHSLib verbosity dirs auto_ghci_libs lib = do
1474 let batch_lib_file = "lib" ++ lib ++ ".a"
1475 filenames = ["lib" ++ lib ++ ".a",
1476 "lib" ++ lib ++ ".p_a",
1477 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so",
1478 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib",
1479 lib ++ "-ghc" ++ Version.version ++ ".dll"]
1480 m <- liftIO $ doesFileExistOnPath filenames dirs
1481 case m of
1482 Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++
1483 " on library path")
1484 Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
1485
1486 doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath)
1487 doesFileExistOnPath filenames paths = go fullFilenames
1488 where fullFilenames = [ (path, path </> filename)
1489 | filename <- filenames
1490 , path <- paths ]
1491 go [] = return Nothing
1492 go ((p, fp) : xs) = do b <- doesFileExist fp
1493 if b then return (Just p) else go xs
1494
1495 checkModules :: InstalledPackageInfo -> Validate ()
1496 checkModules pkg = do
1497 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1498 where
1499 findModule modl =
1500 -- there's no interface file for GHC.Prim
1501 unless (modl == fromString "GHC.Prim") $ do
1502 let files = [ toFilePath modl <.> extension
1503 | extension <- ["hi", "p_hi", "dyn_hi" ] ]
1504 m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
1505 when (isNothing m) $
1506 verror ForceFiles ("cannot find any of " ++ show files)
1507
1508 checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
1509 checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
1510 | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
1511 | otherwise = return ()
1512 where
1513 ghci_lib_file = lib <.> "o"
1514
1515 -- automatically build the GHCi version of a batch lib,
1516 -- using ld --whole-archive.
1517
1518 autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
1519 autoBuildGHCiLib verbosity dir batch_file ghci_file = do
1520 let ghci_lib_file = dir ++ '/':ghci_file
1521 batch_lib_file = dir ++ '/':batch_file
1522 when (verbosity >= Normal) $
1523 info ("building GHCi library " ++ ghci_lib_file ++ "...")
1524 #if defined(darwin_HOST_OS)
1525 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1526 #elif defined(mingw32_HOST_OS)
1527 execDir <- getLibDir
1528 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1529 #else
1530 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1531 #endif
1532 when (r /= ExitSuccess) $ exitWith r
1533 when (verbosity >= Normal) $
1534 infoLn (" done.")
1535
1536 -- -----------------------------------------------------------------------------
1537 -- Searching for modules
1538
1539 #if not_yet
1540
1541 findModules :: [FilePath] -> IO [String]
1542 findModules paths =
1543 mms <- mapM searchDir paths
1544 return (concat mms)
1545
1546 searchDir path prefix = do
1547 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1548 searchEntries path prefix fs
1549
1550 searchEntries path prefix [] = return []
1551 searchEntries path prefix (f:fs)
1552 | looks_like_a_module = do
1553 ms <- searchEntries path prefix fs
1554 return (prefix `joinModule` f : ms)
1555 | looks_like_a_component = do
1556 ms <- searchDir (path </> f) (prefix `joinModule` f)
1557 ms' <- searchEntries path prefix fs
1558 return (ms ++ ms')
1559 | otherwise
1560 searchEntries path prefix fs
1561
1562 where
1563 (base,suffix) = splitFileExt f
1564 looks_like_a_module =
1565 suffix `elem` haskell_suffixes &&
1566 all okInModuleName base
1567 looks_like_a_component =
1568 null suffix && all okInModuleName base
1569
1570 okInModuleName c
1571
1572 #endif
1573
1574 -- ---------------------------------------------------------------------------
1575 -- expanding environment variables in the package configuration
1576
1577 expandEnvVars :: String -> Force -> IO String
1578 expandEnvVars str0 force = go str0 ""
1579 where
1580 go "" acc = return $! reverse acc
1581 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1582 = do value <- lookupEnvVar var
1583 go rest (reverse value ++ acc)
1584 where close c = c == '}' || c == '\n' -- don't span newlines
1585 go (c:str) acc
1586 = go str (c:acc)
1587
1588 lookupEnvVar :: String -> IO String
1589 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1590 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1591 lookupEnvVar nm =
1592 catchIO (System.Environment.getEnv nm)
1593 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1594 show nm)
1595 return "")
1596
1597 -----------------------------------------------------------------------------
1598
1599 getProgramName :: IO String
1600 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1601 where str `withoutSuffix` suff
1602 | suff `isSuffixOf` str = take (length str - length suff) str
1603 | otherwise = str
1604
1605 bye :: String -> IO a
1606 bye s = putStr s >> exitWith ExitSuccess
1607
1608 die :: String -> IO a
1609 die = dieWith 1
1610
1611 dieWith :: Int -> String -> IO a
1612 dieWith ec s = do
1613 prog <- getProgramName
1614 reportError (prog ++ ": " ++ s)
1615 exitWith (ExitFailure ec)
1616
1617 dieOrForceAll :: Force -> String -> IO ()
1618 dieOrForceAll ForceAll s = ignoreError s
1619 dieOrForceAll _other s = dieForcible s
1620
1621 warn :: String -> IO ()
1622 warn = reportError
1623
1624 -- send info messages to stdout
1625 infoLn :: String -> IO ()
1626 infoLn = putStrLn
1627
1628 info :: String -> IO ()
1629 info = putStr
1630
1631 ignoreError :: String -> IO ()
1632 ignoreError s = reportError (s ++ " (ignoring)")
1633
1634 reportError :: String -> IO ()
1635 reportError s = do hFlush stdout; hPutStrLn stderr s
1636
1637 dieForcible :: String -> IO ()
1638 dieForcible s = die (s ++ " (use --force to override)")
1639
1640 my_head :: String -> [a] -> a
1641 my_head s [] = error s
1642 my_head _ (x : _) = x
1643
1644 -----------------------------------------
1645 -- Cut and pasted from ghc/compiler/main/SysTools
1646
1647 #if defined(mingw32_HOST_OS)
1648 subst :: Char -> Char -> String -> String
1649 subst a b ls = map (\ x -> if x == a then b else x) ls
1650
1651 unDosifyPath :: FilePath -> FilePath
1652 unDosifyPath xs = subst '\\' '/' xs
1653
1654 getLibDir :: IO (Maybe String)
1655 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1656
1657 -- (getExecDir cmd) returns the directory in which the current
1658 -- executable, which should be called 'cmd', is running
1659 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1660 -- you'll get "/a/b/c" back as the result
1661 getExecDir :: String -> IO (Maybe String)
1662 getExecDir cmd =
1663 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1664 where initN n = reverse . drop n . reverse
1665 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1666
1667 getExecPath :: IO (Maybe String)
1668 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1669 where
1670 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1671 ret <- c_GetModuleFileName nullPtr buf size
1672 case ret of
1673 0 -> return Nothing
1674 _ | ret < size -> fmap Just $ peekCWString buf
1675 | otherwise -> try_size (size * 2)
1676
1677 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1678 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1679 #else
1680 getLibDir :: IO (Maybe String)
1681 getLibDir = return Nothing
1682 #endif
1683
1684 -----------------------------------------
1685 -- Adapted from ghc/compiler/utils/Panic
1686
1687 installSignalHandlers :: IO ()
1688 installSignalHandlers = do
1689 threadid <- myThreadId
1690 let
1691 interrupt = Exception.throwTo threadid
1692 (Exception.ErrorCall "interrupted")
1693 --
1694 #if !defined(mingw32_HOST_OS)
1695 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1696 _ <- installHandler sigINT (Catch interrupt) Nothing
1697 return ()
1698 #else
1699 -- GHC 6.3+ has support for console events on Windows
1700 -- NOTE: running GHCi under a bash shell for some reason requires
1701 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1702 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1703 -- why --SDM 17/12/2004
1704 let sig_handler ControlC = interrupt
1705 sig_handler Break = interrupt
1706 sig_handler _ = return ()
1707
1708 _ <- installHandler (Catch sig_handler)
1709 return ()
1710 #endif
1711
1712 #if mingw32_HOST_OS || mingw32_TARGET_OS
1713 throwIOIO :: Exception.IOException -> IO a
1714 throwIOIO = Exception.throwIO
1715 #endif
1716
1717 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1718 catchIO = Exception.catch
1719
1720 catchError :: IO a -> (String -> IO a) -> IO a
1721 catchError io handler = io `Exception.catch` handler'
1722 where handler' (Exception.ErrorCall err) = handler err
1723
1724 tryIO :: IO a -> IO (Either Exception.IOException a)
1725 tryIO = Exception.try
1726
1727 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1728 writeBinaryFileAtomic targetFile obj =
1729 withFileAtomic targetFile $ \h -> do
1730 hSetBinaryMode h True
1731 B.hPutStr h (Bin.encode obj)
1732
1733 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1734 writeFileUtf8Atomic targetFile content =
1735 withFileAtomic targetFile $ \h -> do
1736 hSetEncoding h utf8
1737 hPutStr h content
1738
1739 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1740 -- to use text files here, rather than binary files.
1741 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1742 withFileAtomic targetFile write_content = do
1743 (newFile, newHandle) <- openNewFile targetDir template
1744 do write_content newHandle
1745 hClose newHandle
1746 #if mingw32_HOST_OS || mingw32_TARGET_OS
1747 renameFile newFile targetFile
1748 -- If the targetFile exists then renameFile will fail
1749 `catchIO` \err -> do
1750 exists <- doesFileExist targetFile
1751 if exists
1752 then do removeFileSafe targetFile
1753 -- Big fat hairy race condition
1754 renameFile newFile targetFile
1755 -- If the removeFile succeeds and the renameFile fails
1756 -- then we've lost the atomic property.
1757 else throwIOIO err
1758 #else
1759 renameFile newFile targetFile
1760 #endif
1761 `Exception.onException` do hClose newHandle
1762 removeFileSafe newFile
1763 where
1764 template = targetName <.> "tmp"
1765 targetDir | null targetDir_ = "."
1766 | otherwise = targetDir_
1767 --TODO: remove this when takeDirectory/splitFileName is fixed
1768 -- to always return a valid dir
1769 (targetDir_,targetName) = splitFileName targetFile
1770
1771 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1772 openNewFile dir template = do
1773 -- this was added to System.IO in 6.12.1
1774 -- we must use this version because the version below opens the file
1775 -- in binary mode.
1776 openTempFileWithDefaultPermissions dir template
1777
1778 -- | The function splits the given string to substrings
1779 -- using 'isSearchPathSeparator'.
1780 parseSearchPath :: String -> [FilePath]
1781 parseSearchPath path = split path
1782 where
1783 split :: String -> [String]
1784 split s =
1785 case rest' of
1786 [] -> [chunk]
1787 _:rest -> chunk : split rest
1788 where
1789 chunk =
1790 case chunk' of
1791 #ifdef mingw32_HOST_OS
1792 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1793 #endif
1794 _ -> chunk'
1795
1796 (chunk', rest') = break isSearchPathSeparator s
1797
1798 readUTF8File :: FilePath -> IO String
1799 readUTF8File file = do
1800 h <- openFile file ReadMode
1801 -- fix the encoding to UTF-8
1802 hSetEncoding h utf8
1803 hGetContents h
1804
1805 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1806 removeFileSafe :: FilePath -> IO ()
1807 removeFileSafe fn =
1808 removeFile fn `catchIO` \ e ->
1809 when (not $ isDoesNotExistError e) $ ioError e
1810
1811 absolutePath :: FilePath -> IO FilePath
1812 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory