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