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