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