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