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