Cabal submodule update: hole support and tests.
[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 [] ["*"]
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 | not (null path) && isSearchPathSeparator (last path)
604 -> splitSearchPath (init path) ++ sys_databases
605 | otherwise
606 -> splitSearchPath path
607
608 -- The "global" database is always the one at the bottom of the stack.
609 -- This is the database we modify by default.
610 virt_global_conf = last env_stack
611
612 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
613 where is_db_flag FlagUser
614 | Just (user_conf, _user_exists) <- mb_user_conf
615 = Just user_conf
616 is_db_flag FlagGlobal = Just virt_global_conf
617 is_db_flag (FlagConfig f) = Just f
618 is_db_flag _ = Nothing
619
620 let flag_db_names | null db_flags = env_stack
621 | otherwise = reverse (nub db_flags)
622
623 -- For a "modify" command, treat all the databases as
624 -- a stack, where we are modifying the top one, but it
625 -- can refer to packages in databases further down the
626 -- stack.
627
628 -- -f flags on the command line add to the database
629 -- stack, unless any of them are present in the stack
630 -- already.
631 let final_stack = filter (`notElem` env_stack)
632 [ f | FlagConfig f <- reverse my_flags ]
633 ++ env_stack
634
635 -- the database we actually modify is the one mentioned
636 -- rightmost on the command-line.
637 let to_modify
638 | not modify = Nothing
639 | null db_flags = Just virt_global_conf
640 | otherwise = Just (last db_flags)
641
642 db_stack <- sequence
643 [ do db <- readParseDatabase verbosity mb_user_conf modify use_cache db_path
644 if expand_vars then return (mungePackageDBPaths top_dir db)
645 else return db
646 | db_path <- final_stack ]
647
648 let flag_db_stack = [ db | db_name <- flag_db_names,
649 db <- db_stack, location db == db_name ]
650
651 when (verbosity > Normal) $ do
652 infoLn ("db stack: " ++ show (map location db_stack))
653 infoLn ("modifying: " ++ show to_modify)
654 infoLn ("flag db stack: " ++ show (map location flag_db_stack))
655
656 return (db_stack, to_modify, flag_db_stack)
657
658
659 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
660 lookForPackageDBIn dir = do
661 let path_dir = dir </> "package.conf.d"
662 exists_dir <- doesDirectoryExist path_dir
663 if exists_dir then return (Just path_dir) else do
664 let path_file = dir </> "package.conf"
665 exists_file <- doesFileExist path_file
666 if exists_file then return (Just path_file) else return Nothing
667
668 readParseDatabase :: Verbosity
669 -> Maybe (FilePath,Bool)
670 -> Bool -- we will be modifying, not just reading
671 -> Bool -- use cache
672 -> FilePath
673 -> IO PackageDB
674
675 readParseDatabase verbosity mb_user_conf modify use_cache path
676 -- the user database (only) is allowed to be non-existent
677 | Just (user_conf,False) <- mb_user_conf, path == user_conf
678 = mkPackageDB []
679 | otherwise
680 = do e <- tryIO $ getDirectoryContents path
681 case e of
682 Left err
683 | ioeGetErrorType err == InappropriateType ->
684 die ("ghc no longer supports single-file style package databases "
685 ++ "(" ++ path ++ ") use 'ghc-pkg init' to create the database "
686 ++ "with the correct format.")
687 | otherwise -> ioError err
688 Right fs
689 | not use_cache -> ignore_cache (const $ return ())
690 | otherwise -> do
691 let cache = path </> cachefilename
692 tdir <- getModificationTime path
693 e_tcache <- tryIO $ getModificationTime cache
694 case e_tcache of
695 Left ex -> do
696 whenReportCacheErrors $
697 if isDoesNotExistError ex
698 then do
699 warn ("WARNING: cache does not exist: " ++ cache)
700 warn ("ghc will fail to read this package db. " ++
701 "Use 'ghc-pkg recache' to fix.")
702 else do
703 warn ("WARNING: cache cannot be read: " ++ show ex)
704 warn "ghc will fail to read this package db."
705 ignore_cache (const $ return ())
706 Right tcache -> do
707 let compareTimestampToCache file =
708 when (verbosity >= Verbose) $ do
709 tFile <- getModificationTime file
710 compareTimestampToCache' file tFile
711 compareTimestampToCache' file tFile = do
712 let rel = case tcache `compare` tFile of
713 LT -> " (NEWER than cache)"
714 GT -> " (older than cache)"
715 EQ -> " (same as cache)"
716 warn ("Timestamp " ++ show tFile
717 ++ " for " ++ file ++ rel)
718 when (verbosity >= Verbose) $ do
719 warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
720 compareTimestampToCache' path tdir
721 if tcache >= tdir
722 then do
723 when (verbosity > Normal) $
724 infoLn ("using cache: " ++ cache)
725 pkgs <- GhcPkg.readPackageDbForGhcPkg cache
726 mkPackageDB pkgs
727 else do
728 whenReportCacheErrors $ do
729 warn ("WARNING: cache is out of date: " ++ cache)
730 warn ("ghc will see an old view of this " ++
731 "package db. Use 'ghc-pkg recache' to fix.")
732 ignore_cache compareTimestampToCache
733 where
734 ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
735 ignore_cache checkTime = do
736 let confs = filter (".conf" `isSuffixOf`) fs
737 doFile f = do checkTime f
738 parseSingletonPackageConf verbosity f
739 pkgs <- mapM doFile $ map (path </>) confs
740 mkPackageDB pkgs
741
742 -- We normally report cache errors for read-only commands,
743 -- since modify commands because will usually fix the cache.
744 whenReportCacheErrors =
745 when ( verbosity > Normal
746 || verbosity >= Normal && not modify)
747 where
748 mkPackageDB pkgs = do
749 path_abs <- absolutePath path
750 return PackageDB {
751 location = path,
752 locationAbsolute = path_abs,
753 packages = pkgs
754 }
755
756 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
757 parseSingletonPackageConf verbosity file = do
758 when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
759 readUTF8File file >>= fmap fst . parsePackageInfo
760
761 cachefilename :: FilePath
762 cachefilename = "package.cache"
763
764 mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
765 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
766 db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
767 where
768 pkgroot = takeDirectory (locationAbsolute db)
769 -- It so happens that for both styles of package db ("package.conf"
770 -- files and "package.conf.d" dirs) the pkgroot is the parent directory
771 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
772
773 -- TODO: This code is duplicated in compiler/main/Packages.lhs
774 mungePackagePaths :: FilePath -> FilePath
775 -> InstalledPackageInfo -> InstalledPackageInfo
776 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
777 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
778 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
779 -- The "pkgroot" is the directory containing the package database.
780 --
781 -- Also perform a similar substitution for the older GHC-specific
782 -- "$topdir" variable. The "topdir" is the location of the ghc
783 -- installation (obtained from the -B option).
784 mungePackagePaths top_dir pkgroot pkg =
785 pkg {
786 importDirs = munge_paths (importDirs pkg),
787 includeDirs = munge_paths (includeDirs pkg),
788 libraryDirs = munge_paths (libraryDirs pkg),
789 frameworkDirs = munge_paths (frameworkDirs pkg),
790 haddockInterfaces = munge_paths (haddockInterfaces pkg),
791 -- haddock-html is allowed to be either a URL or a file
792 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
793 }
794 where
795 munge_paths = map munge_path
796 munge_urls = map munge_url
797
798 munge_path p
799 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
800 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
801 | otherwise = p
802
803 munge_url p
804 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
805 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
806 | otherwise = p
807
808 toUrlPath r p = "file:///"
809 -- URLs always use posix style '/' separators:
810 ++ FilePath.Posix.joinPath
811 (r : -- We need to drop a leading "/" or "\\"
812 -- if there is one:
813 dropWhile (all isPathSeparator)
814 (FilePath.splitDirectories p))
815
816 -- We could drop the separator here, and then use </> above. However,
817 -- by leaving it in and using ++ we keep the same path separator
818 -- rather than letting FilePath change it to use \ as the separator
819 stripVarPrefix var path = case stripPrefix var path of
820 Just [] -> Just []
821 Just cs@(c : _) | isPathSeparator c -> Just cs
822 _ -> Nothing
823
824
825 -- -----------------------------------------------------------------------------
826 -- Creating a new package DB
827
828 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
829 initPackageDB filename verbosity _flags = do
830 let eexist = die ("cannot create: " ++ filename ++ " already exists")
831 b1 <- doesFileExist filename
832 when b1 eexist
833 b2 <- doesDirectoryExist filename
834 when b2 eexist
835 filename_abs <- absolutePath filename
836 changeDB verbosity [] PackageDB {
837 location = filename, locationAbsolute = filename_abs,
838 packages = []
839 }
840
841 -- -----------------------------------------------------------------------------
842 -- Registering
843
844 registerPackage :: FilePath
845 -> Verbosity
846 -> [Flag]
847 -> Bool -- auto_ghci_libs
848 -> Bool -- multi_instance
849 -> Bool -- expand_env_vars
850 -> Bool -- update
851 -> Force
852 -> IO ()
853 registerPackage input verbosity my_flags auto_ghci_libs multi_instance
854 expand_env_vars update force = do
855 (db_stack, Just to_modify, _flag_dbs) <-
856 getPkgDatabases verbosity True{-modify-} True{-use user-}
857 True{-use cache-} False{-expand vars-} my_flags
858
859 let
860 db_to_operate_on = my_head "register" $
861 filter ((== to_modify).location) db_stack
862 --
863 when (auto_ghci_libs && verbosity >= Silent) $
864 warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
865 --
866 s <-
867 case input of
868 "-" -> do
869 when (verbosity >= Normal) $
870 info "Reading package info from stdin ... "
871 -- fix the encoding to UTF-8, since this is an interchange format
872 hSetEncoding stdin utf8
873 getContents
874 f -> do
875 when (verbosity >= Normal) $
876 info ("Reading package info from " ++ show f ++ " ... ")
877 readUTF8File f
878
879 expanded <- if expand_env_vars then expandEnvVars s force
880 else return s
881
882 (pkg, ws) <- parsePackageInfo expanded
883 when (verbosity >= Normal) $
884 infoLn "done."
885
886 -- report any warnings from the parse phase
887 _ <- reportValidateErrors [] ws
888 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
889
890 -- validate the expanded pkg, but register the unexpanded
891 pkgroot <- absolutePath (takeDirectory to_modify)
892 let top_dir = takeDirectory (location (last db_stack))
893 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
894
895 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
896 -- truncate the stack for validation, because we don't allow
897 -- packages lower in the stack to refer to those higher up.
898 validatePackageConfig pkg_expanded verbosity truncated_stack
899 auto_ghci_libs multi_instance update force
900
901 let
902 -- In the normal mode, we only allow one version of each package, so we
903 -- remove all instances with the same source package id as the one we're
904 -- adding. In the multi instance mode we don't do that, thus allowing
905 -- multiple instances with the same source package id.
906 removes = [ RemovePackage p
907 | not multi_instance,
908 p <- packages db_to_operate_on,
909 sourcePackageId p == sourcePackageId pkg ]
910 --
911 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
912
913 parsePackageInfo
914 :: String
915 -> IO (InstalledPackageInfo, [ValidateWarning])
916 parsePackageInfo str =
917 case parseInstalledPackageInfo str of
918 ParseOk warnings ok -> return (mungePackageInfo ok, ws)
919 where
920 ws = [ msg | PWarning msg <- warnings
921 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
922 ParseFailed err -> case locatedErrorMsg err of
923 (Nothing, s) -> die s
924 (Just l, s) -> die (show l ++ ": " ++ s)
925
926 mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo
927 mungePackageInfo ipi = ipi { packageKey = packageKey' }
928 where
929 packageKey'
930 | OldPackageKey (PackageIdentifier (PackageName "") _) <- packageKey ipi
931 = OldPackageKey (sourcePackageId ipi)
932 | otherwise = packageKey ipi
933
934 -- -----------------------------------------------------------------------------
935 -- Making changes to a package database
936
937 data DBOp = RemovePackage InstalledPackageInfo
938 | AddPackage InstalledPackageInfo
939 | ModifyPackage InstalledPackageInfo
940
941 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
942 changeDB verbosity cmds db = do
943 let db' = updateInternalDB db cmds
944 createDirectoryIfMissing True (location db)
945 changeDBDir verbosity cmds db'
946
947 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
948 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
949 where
950 do_cmd pkgs (RemovePackage p) =
951 filter ((/= installedPackageId p) . installedPackageId) pkgs
952 do_cmd pkgs (AddPackage p) = p : pkgs
953 do_cmd pkgs (ModifyPackage p) =
954 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
955
956
957 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
958 changeDBDir verbosity cmds db = do
959 mapM_ do_cmd cmds
960 updateDBCache verbosity db
961 where
962 do_cmd (RemovePackage p) = do
963 let file = location db </> display (installedPackageId p) <.> "conf"
964 when (verbosity > Normal) $ infoLn ("removing " ++ file)
965 removeFileSafe file
966 do_cmd (AddPackage p) = do
967 let file = location db </> display (installedPackageId p) <.> "conf"
968 when (verbosity > Normal) $ infoLn ("writing " ++ file)
969 writeFileUtf8Atomic file (showInstalledPackageInfo p)
970 do_cmd (ModifyPackage p) =
971 do_cmd (AddPackage p)
972
973 updateDBCache :: Verbosity -> PackageDB -> IO ()
974 updateDBCache verbosity db = do
975 let filename = location db </> cachefilename
976
977 pkgsCabalFormat :: [InstalledPackageInfo]
978 pkgsCabalFormat = packages db
979
980 pkgsGhcCacheFormat :: [PackageCacheFormat]
981 pkgsGhcCacheFormat = map convertPackageInfoToCacheFormat pkgsCabalFormat
982
983 when (verbosity > Normal) $
984 infoLn ("writing cache " ++ filename)
985 GhcPkg.writePackageDb filename pkgsGhcCacheFormat pkgsCabalFormat
986 `catchIO` \e ->
987 if isPermissionError e
988 then die (filename ++ ": you don't have permission to modify this file")
989 else ioError e
990 #ifndef mingw32_HOST_OS
991 status <- getFileStatus filename
992 setFileTimes (location db) (accessTime status) (modificationTime status)
993 #endif
994
995 type PackageCacheFormat = GhcPkg.InstalledPackageInfo
996 String -- installed package id
997 String -- src package id
998 String -- package name
999 String -- package key
1000 ModuleName -- module name
1001
1002 convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
1003 convertPackageInfoToCacheFormat pkg =
1004 GhcPkg.InstalledPackageInfo {
1005 GhcPkg.installedPackageId = display (installedPackageId pkg),
1006 GhcPkg.sourcePackageId = display (sourcePackageId pkg),
1007 GhcPkg.packageName = display (packageName pkg),
1008 GhcPkg.packageVersion = packageVersion pkg,
1009 GhcPkg.packageKey = display (packageKey pkg),
1010 GhcPkg.depends = map display (depends pkg),
1011 GhcPkg.importDirs = importDirs pkg,
1012 GhcPkg.hsLibraries = hsLibraries pkg,
1013 GhcPkg.extraLibraries = extraLibraries pkg,
1014 GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg,
1015 GhcPkg.libraryDirs = libraryDirs pkg,
1016 GhcPkg.frameworks = frameworks pkg,
1017 GhcPkg.frameworkDirs = frameworkDirs pkg,
1018 GhcPkg.ldOptions = ldOptions pkg,
1019 GhcPkg.ccOptions = ccOptions pkg,
1020 GhcPkg.includes = includes pkg,
1021 GhcPkg.includeDirs = includeDirs pkg,
1022 GhcPkg.haddockInterfaces = haddockInterfaces pkg,
1023 GhcPkg.haddockHTMLs = haddockHTMLs pkg,
1024 GhcPkg.exposedModules = map convertExposed (exposedModules pkg),
1025 GhcPkg.hiddenModules = hiddenModules pkg,
1026 GhcPkg.instantiatedWith = map convertInst (instantiatedWith pkg),
1027 GhcPkg.exposed = exposed pkg,
1028 GhcPkg.trusted = trusted pkg
1029 }
1030 where convertExposed (ExposedModule n reexport sig) =
1031 GhcPkg.ExposedModule n (fmap convertOriginal reexport)
1032 (fmap convertOriginal sig)
1033 convertOriginal (OriginalModule ipid m) =
1034 GhcPkg.OriginalModule (display ipid) m
1035 convertInst (m, o) = (m, convertOriginal o)
1036
1037 instance GhcPkg.BinaryStringRep ModuleName where
1038 fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack
1039 toStringRep = BS.pack . toUTF8 . display
1040
1041 instance GhcPkg.BinaryStringRep String where
1042 fromStringRep = fromUTF8 . BS.unpack
1043 toStringRep = BS.pack . toUTF8
1044
1045
1046 -- -----------------------------------------------------------------------------
1047 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
1048
1049 exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1050 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
1051
1052 hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1053 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
1054
1055 trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1056 trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
1057
1058 distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1059 distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
1060
1061 unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1062 unregisterPackage = modifyPackage RemovePackage
1063
1064 modifyPackage
1065 :: (InstalledPackageInfo -> DBOp)
1066 -> PackageArg
1067 -> Verbosity
1068 -> [Flag]
1069 -> Force
1070 -> IO ()
1071 modifyPackage fn pkgarg verbosity my_flags force = do
1072 (db_stack, Just _to_modify, flag_dbs) <-
1073 getPkgDatabases verbosity True{-modify-} True{-use user-}
1074 True{-use cache-} False{-expand vars-} my_flags
1075
1076 -- Do the search for the package respecting flags...
1077 (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg
1078 let
1079 db_name = location db
1080 pkgs = packages db
1081
1082 pks = map packageKey ps
1083
1084 cmds = [ fn pkg | pkg <- pkgs, packageKey pkg `elem` pks ]
1085 new_db = updateInternalDB db cmds
1086
1087 -- ...but do consistency checks with regards to the full stack
1088 old_broken = brokenPackages (allPackagesInStack db_stack)
1089 rest_of_stack = filter ((/= db_name) . location) db_stack
1090 new_stack = new_db : rest_of_stack
1091 new_broken = brokenPackages (allPackagesInStack new_stack)
1092 newly_broken = filter ((`notElem` map packageKey old_broken)
1093 . packageKey) new_broken
1094 --
1095 let displayQualPkgId pkg
1096 | [_] <- filter ((== pkgid) . sourcePackageId)
1097 (allPackagesInStack db_stack)
1098 = display pkgid
1099 | otherwise = display pkgid ++ "@" ++ display (packageKey pkg)
1100 where pkgid = sourcePackageId pkg
1101 when (not (null newly_broken)) $
1102 dieOrForceAll force ("unregistering would break the following packages: "
1103 ++ unwords (map displayQualPkgId newly_broken))
1104
1105 changeDB verbosity cmds db
1106
1107 recache :: Verbosity -> [Flag] -> IO ()
1108 recache verbosity my_flags = do
1109 (db_stack, Just to_modify, _flag_dbs) <-
1110 getPkgDatabases verbosity True{-modify-} True{-use user-} False{-no cache-}
1111 False{-expand vars-} my_flags
1112 let
1113 db_to_operate_on = my_head "recache" $
1114 filter ((== to_modify).location) db_stack
1115 --
1116 changeDB verbosity [] db_to_operate_on
1117
1118 -- -----------------------------------------------------------------------------
1119 -- Listing packages
1120
1121 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
1122 -> Maybe (String->Bool)
1123 -> IO ()
1124 listPackages verbosity my_flags mPackageName mModuleName = do
1125 let simple_output = FlagSimpleOutput `elem` my_flags
1126 (db_stack, _, flag_db_stack) <-
1127 getPkgDatabases verbosity False{-modify-} False{-use user-}
1128 True{-use cache-} False{-expand vars-} my_flags
1129
1130 let db_stack_filtered -- if a package is given, filter out all other packages
1131 | Just this <- mPackageName =
1132 [ db{ packages = filter (this `matchesPkg`) (packages db) }
1133 | db <- flag_db_stack ]
1134 | Just match <- mModuleName = -- packages which expose mModuleName
1135 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
1136 | db <- flag_db_stack ]
1137 | otherwise = flag_db_stack
1138
1139 db_stack_sorted
1140 = [ db{ packages = sort_pkgs (packages db) }
1141 | db <- db_stack_filtered ]
1142 where sort_pkgs = sortBy cmpPkgIds
1143 cmpPkgIds pkg1 pkg2 =
1144 case pkgName p1 `compare` pkgName p2 of
1145 LT -> LT
1146 GT -> GT
1147 EQ -> case pkgVersion p1 `compare` pkgVersion p2 of
1148 LT -> LT
1149 GT -> GT
1150 EQ -> packageKey pkg1 `compare` packageKey pkg2
1151 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
1152
1153 stack = reverse db_stack_sorted
1154
1155 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
1156
1157 pkg_map = allPackagesInStack db_stack
1158 broken = map packageKey (brokenPackages pkg_map)
1159
1160 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
1161 do hPutStrLn stdout (db_name ++ ":")
1162 if null pp_pkgs
1163 then hPutStrLn stdout " (no packages)"
1164 else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs)
1165 where
1166 -- Sort using instance Ord PackageId
1167 pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs
1168 pp_pkg p
1169 | packageKey p `elem` broken = printf "{%s}" doc
1170 | exposed p = doc
1171 | otherwise = printf "(%s)" doc
1172 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
1173 | otherwise = pkg
1174 where
1175 InstalledPackageId ipid = installedPackageId p
1176 pkg = display (sourcePackageId p)
1177
1178 show_simple = simplePackageList my_flags . allPackagesInStack
1179
1180 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
1181 prog <- getProgramName
1182 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
1183
1184 if simple_output then show_simple stack else do
1185
1186 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
1187 mapM_ show_normal stack
1188 #else
1189 let
1190 show_colour withF db =
1191 mconcat $ map (<#> termText "\n") $
1192 (termText (location db) :
1193 map (termText " " <#>) (map pp_pkg (packages db)))
1194 where
1195 pp_pkg p
1196 | packageKey p `elem` broken = withF Red doc
1197 | exposed p = doc
1198 | otherwise = withF Blue doc
1199 where doc | verbosity >= Verbose
1200 = termText (printf "%s (%s)" pkg ipid)
1201 | otherwise
1202 = termText pkg
1203 where
1204 InstalledPackageId ipid = installedPackageId p
1205 pkg = display (sourcePackageId p)
1206
1207 is_tty <- hIsTerminalDevice stdout
1208 if not is_tty
1209 then mapM_ show_normal stack
1210 else do tty <- Terminfo.setupTermFromEnv
1211 case Terminfo.getCapability tty withForegroundColor of
1212 Nothing -> mapM_ show_normal stack
1213 Just w -> runTermOutput tty $ mconcat $
1214 map (show_colour w) stack
1215 #endif
1216
1217 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1218 simplePackageList my_flags pkgs = do
1219 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1220 else display
1221 -- Sort using instance Ord PackageId
1222 strs = map showPkg $ sort $ map sourcePackageId pkgs
1223 when (not (null pkgs)) $
1224 hPutStrLn stdout $ concat $ intersperse " " strs
1225
1226 showPackageDot :: Verbosity -> [Flag] -> IO ()
1227 showPackageDot verbosity myflags = do
1228 (_, _, flag_db_stack) <-
1229 getPkgDatabases verbosity False{-modify-} False{-use user-}
1230 True{-use cache-} False{-expand vars-} myflags
1231
1232 let all_pkgs = allPackagesInStack flag_db_stack
1233 ipix = PackageIndex.fromList all_pkgs
1234
1235 putStrLn "digraph {"
1236 let quote s = '"':s ++ "\""
1237 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1238 | p <- all_pkgs,
1239 let from = display (sourcePackageId p),
1240 depid <- depends p,
1241 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
1242 let to = display (sourcePackageId dep)
1243 ]
1244 putStrLn "}"
1245
1246 -- -----------------------------------------------------------------------------
1247 -- Prints the highest (hidden or exposed) version of a package
1248
1249 -- ToDo: This is no longer well-defined with package keys, because the
1250 -- dependencies may be varying versions
1251 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
1252 latestPackage verbosity my_flags pkgid = do
1253 (_, _, flag_db_stack) <-
1254 getPkgDatabases verbosity False{-modify-} False{-use user-}
1255 True{-use cache-} False{-expand vars-} my_flags
1256
1257 ps <- findPackages flag_db_stack (Id pkgid)
1258 case ps of
1259 [] -> die "no matches"
1260 _ -> show_pkg . maximum . map sourcePackageId $ ps
1261 where
1262 show_pkg pid = hPutStrLn stdout (display pid)
1263
1264 -- -----------------------------------------------------------------------------
1265 -- Describe
1266
1267 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1268 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1269 (_, _, flag_db_stack) <-
1270 getPkgDatabases verbosity False{-modify-} False{-use user-}
1271 True{-use cache-} expand_pkgroot my_flags
1272 dbs <- findPackagesByDB flag_db_stack pkgarg
1273 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1274 | (db, pkgs) <- dbs, pkg <- pkgs ]
1275
1276 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1277 dumpPackages verbosity my_flags expand_pkgroot = do
1278 (_, _, flag_db_stack) <-
1279 getPkgDatabases verbosity False{-modify-} False{-use user-}
1280 True{-use cache-} expand_pkgroot my_flags
1281 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1282 | db <- flag_db_stack, pkg <- packages db ]
1283
1284 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1285 doDump expand_pkgroot pkgs = do
1286 -- fix the encoding to UTF-8, since this is an interchange format
1287 hSetEncoding stdout utf8
1288 putStrLn $
1289 intercalate "---\n"
1290 [ if expand_pkgroot
1291 then showInstalledPackageInfo pkg
1292 else showInstalledPackageInfo pkg ++ pkgrootField
1293 | (pkg, pkgloc) <- pkgs
1294 , let pkgroot = takeDirectory pkgloc
1295 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
1296
1297 -- PackageId is can have globVersion for the version
1298 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1299 findPackages db_stack pkgarg
1300 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1301
1302 findPackagesByDB :: PackageDBStack -> PackageArg
1303 -> IO [(PackageDB, [InstalledPackageInfo])]
1304 findPackagesByDB db_stack pkgarg
1305 = case [ (db, matched)
1306 | db <- db_stack,
1307 let matched = filter (pkgarg `matchesPkg`) (packages db),
1308 not (null matched) ] of
1309 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
1310 ps -> return ps
1311 where
1312 pkg_msg (Id pkgid) = display pkgid
1313 pkg_msg (IPId ipid) = display ipid
1314 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1315
1316 matches :: PackageIdentifier -> PackageIdentifier -> Bool
1317 pid `matches` pid'
1318 = (pkgName pid == pkgName pid')
1319 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
1320
1321 realVersion :: PackageIdentifier -> Bool
1322 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
1323 -- when versionBranch == [], this is a glob
1324
1325 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1326 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1327 (IPId ipid) `matchesPkg` pkg = ipid == installedPackageId pkg
1328 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1329
1330 -- -----------------------------------------------------------------------------
1331 -- Field
1332
1333 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1334 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1335 (_, _, flag_db_stack) <-
1336 getPkgDatabases verbosity False{-modify-} False{-use user-}
1337 True{-use cache-} expand_pkgroot my_flags
1338 fns <- mapM toField fields
1339 ps <- findPackages flag_db_stack pkgarg
1340 mapM_ (selectFields fns) ps
1341 where showFun = if FlagSimpleOutput `elem` my_flags
1342 then showSimpleInstalledPackageInfoField
1343 else showInstalledPackageInfoField
1344 toField f = case showFun f of
1345 Nothing -> die ("unknown field: " ++ f)
1346 Just fn -> return fn
1347 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
1348
1349
1350 -- -----------------------------------------------------------------------------
1351 -- Check: Check consistency of installed packages
1352
1353 checkConsistency :: Verbosity -> [Flag] -> IO ()
1354 checkConsistency verbosity my_flags = do
1355 (db_stack, _, _) <-
1356 getPkgDatabases verbosity False{-modify-} True{-use user-}
1357 True{-use cache-} True{-expand vars-}
1358 my_flags
1359 -- although check is not a modify command, we do need to use the user
1360 -- db, because we may need it to verify package deps.
1361
1362 let simple_output = FlagSimpleOutput `elem` my_flags
1363
1364 let pkgs = allPackagesInStack db_stack
1365
1366 checkPackage p = do
1367 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
1368 False True True
1369 if null es
1370 then do when (not simple_output) $ do
1371 _ <- reportValidateErrors [] ws "" Nothing
1372 return ()
1373 return []
1374 else do
1375 when (not simple_output) $ do
1376 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1377 _ <- reportValidateErrors es ws " " Nothing
1378 return ()
1379 return [p]
1380
1381 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1382
1383 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1384 where not_in p = sourcePackageId p `notElem` all_ps
1385 all_ps = map sourcePackageId pkgs1
1386
1387 let not_broken_pkgs = filterOut broken_pkgs pkgs
1388 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1389 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1390
1391 when (not (null all_broken_pkgs)) $ do
1392 if simple_output
1393 then simplePackageList my_flags all_broken_pkgs
1394 else do
1395 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1396 "listed above, or because they depend on a broken package.")
1397 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1398
1399 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1400
1401
1402 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1403 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1404 closure pkgs db_stack = go pkgs db_stack
1405 where
1406 go avail not_avail =
1407 case partition (depsAvailable avail) not_avail of
1408 ([], not_avail') -> (avail, not_avail')
1409 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1410
1411 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1412 -> Bool
1413 depsAvailable pkgs_ok pkg = null dangling
1414 where dangling = filter (`notElem` pids) (depends pkg)
1415 pids = map installedPackageId pkgs_ok
1416
1417 -- we want mutually recursive groups of package to show up
1418 -- as broken. (#1750)
1419
1420 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1421 brokenPackages pkgs = snd (closure [] pkgs)
1422
1423 -----------------------------------------------------------------------------
1424 -- Sanity-check a new package config, and automatically build GHCi libs
1425 -- if requested.
1426
1427 type ValidateError = (Force,String)
1428 type ValidateWarning = String
1429
1430 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1431
1432 instance Functor Validate where
1433 fmap = liftM
1434
1435 instance Applicative Validate where
1436 pure = return
1437 (<*>) = ap
1438
1439 instance Monad Validate where
1440 return a = V $ return (a, [], [])
1441 m >>= k = V $ do
1442 (a, es, ws) <- runValidate m
1443 (b, es', ws') <- runValidate (k a)
1444 return (b,es++es',ws++ws')
1445
1446 verror :: Force -> String -> Validate ()
1447 verror f s = V (return ((),[(f,s)],[]))
1448
1449 vwarn :: String -> Validate ()
1450 vwarn s = V (return ((),[],["Warning: " ++ s]))
1451
1452 liftIO :: IO a -> Validate a
1453 liftIO k = V (k >>= \a -> return (a,[],[]))
1454
1455 -- returns False if we should die
1456 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1457 -> String -> Maybe Force -> IO Bool
1458 reportValidateErrors es ws prefix mb_force = do
1459 mapM_ (warn . (prefix++)) ws
1460 oks <- mapM report es
1461 return (and oks)
1462 where
1463 report (f,s)
1464 | Just force <- mb_force
1465 = if (force >= f)
1466 then do reportError (prefix ++ s ++ " (ignoring)")
1467 return True
1468 else if f < CannotForce
1469 then do reportError (prefix ++ s ++ " (use --force to override)")
1470 return False
1471 else do reportError err
1472 return False
1473 | otherwise = do reportError err
1474 return False
1475 where
1476 err = prefix ++ s
1477
1478 validatePackageConfig :: InstalledPackageInfo
1479 -> Verbosity
1480 -> PackageDBStack
1481 -> Bool -- auto-ghc-libs
1482 -> Bool -- multi_instance
1483 -> Bool -- update, or check
1484 -> Force
1485 -> IO ()
1486 validatePackageConfig pkg verbosity db_stack auto_ghci_libs
1487 multi_instance update force = do
1488 (_,es,ws) <- runValidate $
1489 checkPackageConfig pkg verbosity db_stack
1490 auto_ghci_libs multi_instance update
1491 ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1492 when (not ok) $ exitWith (ExitFailure 1)
1493
1494 checkPackageConfig :: InstalledPackageInfo
1495 -> Verbosity
1496 -> PackageDBStack
1497 -> Bool -- auto-ghc-libs
1498 -> Bool -- multi_instance
1499 -> Bool -- update, or check
1500 -> Validate ()
1501 checkPackageConfig pkg verbosity db_stack auto_ghci_libs
1502 multi_instance update = do
1503 checkInstalledPackageId pkg db_stack update
1504 checkPackageId pkg
1505 checkPackageKey pkg
1506 checkDuplicates db_stack pkg multi_instance update
1507 mapM_ (checkDep db_stack) (depends pkg)
1508 checkDuplicateDepends (depends pkg)
1509 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1510 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1511 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1512 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1513 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1514 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1515 checkDuplicateModules pkg
1516 checkExposedModules db_stack pkg
1517 checkOtherModules pkg
1518 mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1519 -- ToDo: check these somehow?
1520 -- extra_libraries :: [String],
1521 -- c_includes :: [String],
1522
1523 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1524 -> Validate ()
1525 checkInstalledPackageId ipi db_stack update = do
1526 let ipid@(InstalledPackageId str) = installedPackageId ipi
1527 when (null str) $ verror CannotForce "missing id field"
1528 let dups = [ p | p <- allPackagesInStack db_stack,
1529 installedPackageId p == ipid ]
1530 when (not update && not (null dups)) $
1531 verror CannotForce $
1532 "package(s) with this id already exist: " ++
1533 unwords (map (display.packageId) dups)
1534
1535 -- When the package name and version are put together, sometimes we can
1536 -- end up with a package id that cannot be parsed. This will lead to
1537 -- difficulties when the user wants to refer to the package later, so
1538 -- we check that the package id can be parsed properly here.
1539 checkPackageId :: InstalledPackageInfo -> Validate ()
1540 checkPackageId ipi =
1541 let str = display (sourcePackageId ipi) in
1542 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1543 [_] -> return ()
1544 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1545 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1546
1547 checkPackageKey :: InstalledPackageInfo -> Validate ()
1548 checkPackageKey ipi =
1549 let str = display (packageKey ipi) in
1550 case [ x :: PackageKey | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1551 [_] -> return ()
1552 [] -> verror CannotForce ("invalid package key: " ++ str)
1553 _ -> verror CannotForce ("ambiguous package key: " ++ str)
1554
1555 checkDuplicates :: PackageDBStack -> InstalledPackageInfo
1556 -> Bool -> Bool-> Validate ()
1557 checkDuplicates db_stack pkg multi_instance update = do
1558 let
1559 pkgid = sourcePackageId pkg
1560 pkgs = packages (head db_stack)
1561 --
1562 -- Check whether this package id already exists in this DB
1563 --
1564 when (not update && not multi_instance
1565 && (pkgid `elem` map sourcePackageId pkgs)) $
1566 verror CannotForce $
1567 "package " ++ display pkgid ++ " is already installed"
1568
1569 let
1570 uncasep = map toLower . display
1571 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1572
1573 when (not update && not (null dups)) $ verror ForceAll $
1574 "Package names may be treated case-insensitively in the future.\n"++
1575 "Package " ++ display pkgid ++
1576 " overlaps with: " ++ unwords (map display dups)
1577
1578 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1579 checkDir = checkPath False True
1580 checkFile = checkPath False False
1581 checkDirURL = checkPath True True
1582
1583 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1584 checkPath url_ok is_dir warn_only thisfield d
1585 | url_ok && ("http://" `isPrefixOf` d
1586 || "https://" `isPrefixOf` d) = return ()
1587
1588 | url_ok
1589 , Just d' <- stripPrefix "file://" d
1590 = checkPath False is_dir warn_only thisfield d'
1591
1592 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1593 -- variables having been expanded already, see mungePackagePaths.
1594
1595 | isRelative d = verror ForceFiles $
1596 thisfield ++ ": " ++ d ++ " is a relative path which "
1597 ++ "makes no sense (as there is nothing for it to be "
1598 ++ "relative to). You can make paths relative to the "
1599 ++ "package database itself by using ${pkgroot}."
1600 -- relative paths don't make any sense; #4134
1601 | otherwise = do
1602 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1603 when (not there) $
1604 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1605 ++ if is_dir then "directory" else "file"
1606 in
1607 if warn_only
1608 then vwarn msg
1609 else verror ForceFiles msg
1610
1611 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1612 checkDep db_stack pkgid
1613 | pkgid `elem` pkgids = return ()
1614 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1615 ++ "\" doesn't exist")
1616 where
1617 all_pkgs = allPackagesInStack db_stack
1618 pkgids = map installedPackageId all_pkgs
1619
1620 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1621 checkDuplicateDepends deps
1622 | null dups = return ()
1623 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1624 unwords (map display dups))
1625 where
1626 dups = [ p | (p:_:_) <- group (sort deps) ]
1627
1628 checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
1629 checkHSLib verbosity dirs auto_ghci_libs lib = do
1630 let batch_lib_file = "lib" ++ lib ++ ".a"
1631 filenames = ["lib" ++ lib ++ ".a",
1632 "lib" ++ lib ++ ".p_a",
1633 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so",
1634 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib",
1635 lib ++ "-ghc" ++ Version.version ++ ".dll"]
1636 m <- liftIO $ doesFileExistOnPath filenames dirs
1637 case m of
1638 Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++
1639 " on library path")
1640 Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
1641
1642 doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath)
1643 doesFileExistOnPath filenames paths = go fullFilenames
1644 where fullFilenames = [ (path, path </> filename)
1645 | filename <- filenames
1646 , path <- paths ]
1647 go [] = return Nothing
1648 go ((p, fp) : xs) = do b <- doesFileExist fp
1649 if b then return (Just p) else go xs
1650
1651 -- | Perform validation checks (module file existence checks) on the
1652 -- @hidden-modules@ field.
1653 checkOtherModules :: InstalledPackageInfo -> Validate ()
1654 checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg)
1655
1656 -- | Perform validation checks (module file existence checks and module
1657 -- reexport checks) on the @exposed-modules@ field.
1658 checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate ()
1659 checkExposedModules db_stack pkg =
1660 mapM_ checkExposedModule (exposedModules pkg)
1661 where
1662 checkExposedModule (ExposedModule modl reexport _sig) = do
1663 let checkOriginal = checkModuleFile pkg modl
1664 checkReexport = checkOriginalModule "module reexport" db_stack pkg
1665 maybe checkOriginal checkReexport reexport
1666
1667 -- | Validates the existence of an appropriate @hi@ file associated with
1668 -- a module. Used for both @hidden-modules@ and @exposed-modules@ which
1669 -- are not reexports.
1670 checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate ()
1671 checkModuleFile pkg modl =
1672 -- there's no interface file for GHC.Prim
1673 unless (modl == ModuleName.fromString "GHC.Prim") $ do
1674 let files = [ ModuleName.toFilePath modl <.> extension
1675 | extension <- ["hi", "p_hi", "dyn_hi" ] ]
1676 m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
1677 when (isNothing m) $
1678 verror ForceFiles ("cannot find any of " ++ show files)
1679
1680 -- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate
1681 -- entries.
1682 -- ToDo: this needs updating for signatures: signatures can validly show up
1683 -- multiple times in the @exposed-modules@ list as long as their backing
1684 -- implementations agree.
1685 checkDuplicateModules :: InstalledPackageInfo -> Validate ()
1686 checkDuplicateModules pkg
1687 | null dups = return ()
1688 | otherwise = verror ForceAll ("package has duplicate modules: " ++
1689 unwords (map display dups))
1690 where
1691 dups = [ m | (m:_:_) <- group (sort mods) ]
1692 mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg
1693
1694 -- | Validates an original module entry, either the origin of a module reexport
1695 -- or the backing implementation of a signature, by checking that it exists,
1696 -- really is an original definition, and is accessible from the dependencies of
1697 -- the package.
1698 -- ToDo: If the original module in question is a backing signature
1699 -- implementation, then we should also check that the original module in
1700 -- question is NOT a signature (however, if it is a reexport, then it's fine
1701 -- for the original module to be a signature.)
1702 checkOriginalModule :: String
1703 -> PackageDBStack
1704 -> InstalledPackageInfo
1705 -> OriginalModule
1706 -> Validate ()
1707 checkOriginalModule fieldName db_stack pkg
1708 (OriginalModule definingPkgId definingModule) =
1709 let mpkg = if definingPkgId == installedPackageId pkg
1710 then Just pkg
1711 else PackageIndex.lookupInstalledPackageId ipix definingPkgId
1712 in case mpkg of
1713 Nothing
1714 -> verror ForceAll (fieldName ++ " refers to a non-existent " ++
1715 "defining package: " ++
1716 display definingPkgId)
1717
1718 Just definingPkg
1719 | not (isIndirectDependency definingPkgId)
1720 -> verror ForceAll (fieldName ++ " refers to a defining " ++
1721 "package that is not a direct (or indirect) " ++
1722 "dependency of this package: " ++
1723 display definingPkgId)
1724
1725 | otherwise
1726 -> case find ((==definingModule).exposedName)
1727 (exposedModules definingPkg) of
1728 Nothing ->
1729 verror ForceAll (fieldName ++ " refers to a module " ++
1730 display definingModule ++ " " ++
1731 "that is not exposed in the " ++
1732 "defining package " ++ display definingPkgId)
1733 Just (ExposedModule {exposedReexport = Just _} ) ->
1734 verror ForceAll (fieldName ++ " refers to a module " ++
1735 display definingModule ++ " " ++
1736 "that is reexported but not defined in the " ++
1737 "defining package " ++ display definingPkgId)
1738 _ -> return ()
1739
1740 where
1741 all_pkgs = allPackagesInStack db_stack
1742 ipix = PackageIndex.fromList all_pkgs
1743
1744 isIndirectDependency pkgid = fromMaybe False $ do
1745 thispkg <- graphVertex (installedPackageId pkg)
1746 otherpkg <- graphVertex pkgid
1747 return (Graph.path depgraph thispkg otherpkg)
1748 (depgraph, _, graphVertex) =
1749 PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix)
1750
1751
1752 checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
1753 checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
1754 | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
1755 | otherwise = return ()
1756 where
1757 ghci_lib_file = lib <.> "o"
1758
1759 -- automatically build the GHCi version of a batch lib,
1760 -- using ld --whole-archive.
1761
1762 autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
1763 autoBuildGHCiLib verbosity dir batch_file ghci_file = do
1764 let ghci_lib_file = dir ++ '/':ghci_file
1765 batch_lib_file = dir ++ '/':batch_file
1766 when (verbosity >= Normal) $
1767 info ("building GHCi library " ++ ghci_lib_file ++ "...")
1768 #if defined(darwin_HOST_OS)
1769 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1770 #elif defined(mingw32_HOST_OS)
1771 execDir <- getLibDir
1772 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1773 #else
1774 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1775 #endif
1776 when (r /= ExitSuccess) $ exitWith r
1777 when (verbosity >= Normal) $
1778 infoLn (" done.")
1779
1780 -- -----------------------------------------------------------------------------
1781 -- Searching for modules
1782
1783 #if not_yet
1784
1785 findModules :: [FilePath] -> IO [String]
1786 findModules paths =
1787 mms <- mapM searchDir paths
1788 return (concat mms)
1789
1790 searchDir path prefix = do
1791 fs <- getDirectoryEntries path `catchIO` \_ -> return []
1792 searchEntries path prefix fs
1793
1794 searchEntries path prefix [] = return []
1795 searchEntries path prefix (f:fs)
1796 | looks_like_a_module = do
1797 ms <- searchEntries path prefix fs
1798 return (prefix `joinModule` f : ms)
1799 | looks_like_a_component = do
1800 ms <- searchDir (path </> f) (prefix `joinModule` f)
1801 ms' <- searchEntries path prefix fs
1802 return (ms ++ ms')
1803 | otherwise
1804 searchEntries path prefix fs
1805
1806 where
1807 (base,suffix) = splitFileExt f
1808 looks_like_a_module =
1809 suffix `elem` haskell_suffixes &&
1810 all okInModuleName base
1811 looks_like_a_component =
1812 null suffix && all okInModuleName base
1813
1814 okInModuleName c
1815
1816 #endif
1817
1818 -- ---------------------------------------------------------------------------
1819 -- expanding environment variables in the package configuration
1820
1821 expandEnvVars :: String -> Force -> IO String
1822 expandEnvVars str0 force = go str0 ""
1823 where
1824 go "" acc = return $! reverse acc
1825 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1826 = do value <- lookupEnvVar var
1827 go rest (reverse value ++ acc)
1828 where close c = c == '}' || c == '\n' -- don't span newlines
1829 go (c:str) acc
1830 = go str (c:acc)
1831
1832 lookupEnvVar :: String -> IO String
1833 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
1834 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
1835 lookupEnvVar nm =
1836 catchIO (System.Environment.getEnv nm)
1837 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1838 show nm)
1839 return "")
1840
1841 -----------------------------------------------------------------------------
1842
1843 getProgramName :: IO String
1844 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1845 where str `withoutSuffix` suff
1846 | suff `isSuffixOf` str = take (length str - length suff) str
1847 | otherwise = str
1848
1849 bye :: String -> IO a
1850 bye s = putStr s >> exitWith ExitSuccess
1851
1852 die :: String -> IO a
1853 die = dieWith 1
1854
1855 dieWith :: Int -> String -> IO a
1856 dieWith ec s = do
1857 prog <- getProgramName
1858 reportError (prog ++ ": " ++ s)
1859 exitWith (ExitFailure ec)
1860
1861 dieOrForceAll :: Force -> String -> IO ()
1862 dieOrForceAll ForceAll s = ignoreError s
1863 dieOrForceAll _other s = dieForcible s
1864
1865 warn :: String -> IO ()
1866 warn = reportError
1867
1868 -- send info messages to stdout
1869 infoLn :: String -> IO ()
1870 infoLn = putStrLn
1871
1872 info :: String -> IO ()
1873 info = putStr
1874
1875 ignoreError :: String -> IO ()
1876 ignoreError s = reportError (s ++ " (ignoring)")
1877
1878 reportError :: String -> IO ()
1879 reportError s = do hFlush stdout; hPutStrLn stderr s
1880
1881 dieForcible :: String -> IO ()
1882 dieForcible s = die (s ++ " (use --force to override)")
1883
1884 my_head :: String -> [a] -> a
1885 my_head s [] = error s
1886 my_head _ (x : _) = x
1887
1888 -----------------------------------------
1889 -- Cut and pasted from ghc/compiler/main/SysTools
1890
1891 #if defined(mingw32_HOST_OS)
1892 subst :: Char -> Char -> String -> String
1893 subst a b ls = map (\ x -> if x == a then b else x) ls
1894
1895 unDosifyPath :: FilePath -> FilePath
1896 unDosifyPath xs = subst '\\' '/' xs
1897
1898 getLibDir :: IO (Maybe String)
1899 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1900
1901 -- (getExecDir cmd) returns the directory in which the current
1902 -- executable, which should be called 'cmd', is running
1903 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1904 -- you'll get "/a/b/c" back as the result
1905 getExecDir :: String -> IO (Maybe String)
1906 getExecDir cmd =
1907 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1908 where initN n = reverse . drop n . reverse
1909 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1910
1911 getExecPath :: IO (Maybe String)
1912 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1913 where
1914 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1915 ret <- c_GetModuleFileName nullPtr buf size
1916 case ret of
1917 0 -> return Nothing
1918 _ | ret < size -> fmap Just $ peekCWString buf
1919 | otherwise -> try_size (size * 2)
1920
1921 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1922 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1923 #else
1924 getLibDir :: IO (Maybe String)
1925 getLibDir = return Nothing
1926 #endif
1927
1928 -----------------------------------------
1929 -- Adapted from ghc/compiler/utils/Panic
1930
1931 installSignalHandlers :: IO ()
1932 installSignalHandlers = do
1933 threadid <- myThreadId
1934 let
1935 interrupt = Exception.throwTo threadid
1936 (Exception.ErrorCall "interrupted")
1937 --
1938 #if !defined(mingw32_HOST_OS)
1939 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1940 _ <- installHandler sigINT (Catch interrupt) Nothing
1941 return ()
1942 #else
1943 -- GHC 6.3+ has support for console events on Windows
1944 -- NOTE: running GHCi under a bash shell for some reason requires
1945 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1946 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1947 -- why --SDM 17/12/2004
1948 let sig_handler ControlC = interrupt
1949 sig_handler Break = interrupt
1950 sig_handler _ = return ()
1951
1952 _ <- installHandler (Catch sig_handler)
1953 return ()
1954 #endif
1955
1956 #if mingw32_HOST_OS || mingw32_TARGET_OS
1957 throwIOIO :: Exception.IOException -> IO a
1958 throwIOIO = Exception.throwIO
1959 #endif
1960
1961 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1962 catchIO = Exception.catch
1963
1964 tryIO :: IO a -> IO (Either Exception.IOException a)
1965 tryIO = Exception.try
1966
1967 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1968 writeFileUtf8Atomic targetFile content =
1969 withFileAtomic targetFile $ \h -> do
1970 hSetEncoding h utf8
1971 hPutStr h content
1972
1973 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1974 -- to use text files here, rather than binary files.
1975 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1976 withFileAtomic targetFile write_content = do
1977 (newFile, newHandle) <- openNewFile targetDir template
1978 do write_content newHandle
1979 hClose newHandle
1980 #if mingw32_HOST_OS || mingw32_TARGET_OS
1981 renameFile newFile targetFile
1982 -- If the targetFile exists then renameFile will fail
1983 `catchIO` \err -> do
1984 exists <- doesFileExist targetFile
1985 if exists
1986 then do removeFileSafe targetFile
1987 -- Big fat hairy race condition
1988 renameFile newFile targetFile
1989 -- If the removeFile succeeds and the renameFile fails
1990 -- then we've lost the atomic property.
1991 else throwIOIO err
1992 #else
1993 renameFile newFile targetFile
1994 #endif
1995 `Exception.onException` do hClose newHandle
1996 removeFileSafe newFile
1997 where
1998 template = targetName <.> "tmp"
1999 targetDir | null targetDir_ = "."
2000 | otherwise = targetDir_
2001 --TODO: remove this when takeDirectory/splitFileName is fixed
2002 -- to always return a valid dir
2003 (targetDir_,targetName) = splitFileName targetFile
2004
2005 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
2006 openNewFile dir template = do
2007 -- this was added to System.IO in 6.12.1
2008 -- we must use this version because the version below opens the file
2009 -- in binary mode.
2010 openTempFileWithDefaultPermissions dir template
2011
2012 readUTF8File :: FilePath -> IO String
2013 readUTF8File file = do
2014 h <- openFile file ReadMode
2015 -- fix the encoding to UTF-8
2016 hSetEncoding h utf8
2017 hGetContents h
2018
2019 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
2020 removeFileSafe :: FilePath -> IO ()
2021 removeFileSafe fn =
2022 removeFile fn `catchIO` \ e ->
2023 when (not $ isDoesNotExistError e) $ ioError e
2024
2025 absolutePath :: FilePath -> IO FilePath
2026 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory