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