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