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