follow changes in Distribution.Simple.PackageIndex API
[ghc.git] / utils / ghc-pkg / Main.hs
1 {-# OPTIONS -fglasgow-exts -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.Package hiding (depends)
20 import Distribution.Text
21 import Distribution.Version
22 import System.FilePath
23 import System.Cmd ( rawSystem )
24 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
25 getModificationTime )
26 import Text.Printf
27
28 import Prelude
29
30 #include "../../includes/ghcconfig.h"
31
32 import System.Console.GetOpt
33 #if __GLASGOW_HASKELL__ >= 609
34 import qualified Control.Exception as Exception
35 #else
36 import qualified Control.Exception.Extensible as Exception
37 #endif
38 import Data.Maybe
39
40 import Data.Char ( isSpace, toLower )
41 import Control.Monad
42 import System.Directory ( doesDirectoryExist, getDirectoryContents,
43 doesFileExist, renameFile, removeFile )
44 import System.Exit ( exitWith, ExitCode(..) )
45 import System.Environment ( getArgs, getProgName, getEnv )
46 import System.IO
47 import System.IO.Error (try)
48 import Data.List
49 import Control.Concurrent
50
51 import qualified Data.ByteString.Lazy as B
52 import qualified Data.Binary as Bin
53 import qualified Data.Binary.Get as Bin
54
55 import Foreign
56 import Foreign.C
57 #ifdef mingw32_HOST_OS
58 import GHC.ConsoleHandler
59 #else
60 import System.Posix hiding (fdToHandle)
61 #endif
62
63 import IO ( isPermissionError )
64 import System.Posix.Internals
65 #if __GLASGOW_HASKELL__ >= 611
66 import GHC.IO.Handle.FD (fdToHandle)
67 #else
68 import GHC.Handle (fdToHandle)
69 #endif
70
71 #if defined(GLOB)
72 import System.Process(runInteractiveCommand)
73 import qualified System.Info(os)
74 #endif
75
76 #if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
77 import System.Console.Terminfo as Terminfo
78 #endif
79
80 -- -----------------------------------------------------------------------------
81 -- Entry point
82
83 main :: IO ()
84 main = do
85 args <- getArgs
86
87 case getOpt Permute (flags ++ deprecFlags) args of
88 (cli,_,[]) | FlagHelp `elem` cli -> do
89 prog <- getProgramName
90 bye (usageInfo (usageHeader prog) flags)
91 (cli,_,[]) | FlagVersion `elem` cli ->
92 bye ourCopyright
93 (cli,nonopts,[]) ->
94 case getVerbosity Normal cli of
95 Right v -> runit v cli nonopts
96 Left err -> die err
97 (_,_,errors) -> do
98 prog <- getProgramName
99 die (concat errors ++ usageInfo (usageHeader prog) flags)
100
101 -- -----------------------------------------------------------------------------
102 -- Command-line syntax
103
104 data Flag
105 = FlagUser
106 | FlagGlobal
107 | FlagHelp
108 | FlagVersion
109 | FlagConfig FilePath
110 | FlagGlobalConfig FilePath
111 | FlagForce
112 | FlagForceFiles
113 | FlagAutoGHCiLibs
114 | FlagSimpleOutput
115 | FlagNamesOnly
116 | FlagIgnoreCase
117 | FlagNoUserDb
118 | FlagVerbosity (Maybe String)
119 deriving Eq
120
121 flags :: [OptDescr Flag]
122 flags = [
123 Option [] ["user"] (NoArg FlagUser)
124 "use the current user's package database",
125 Option [] ["global"] (NoArg FlagGlobal)
126 "use the global package database",
127 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
128 "use the specified package config file",
129 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
130 "location of the global package config",
131 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
132 "never read the user package database",
133 Option [] ["force"] (NoArg FlagForce)
134 "ignore missing dependencies, directories, and libraries",
135 Option [] ["force-files"] (NoArg FlagForceFiles)
136 "ignore missing directories and libraries only",
137 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
138 "automatically build libs for GHCi (with register)",
139 Option ['?'] ["help"] (NoArg FlagHelp)
140 "display this help and exit",
141 Option ['V'] ["version"] (NoArg FlagVersion)
142 "output version information and exit",
143 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
144 "print output in easy-to-parse format for some commands",
145 Option [] ["names-only"] (NoArg FlagNamesOnly)
146 "only print package names, not versions; can only be used with list --simple-output",
147 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
148 "ignore case for substring matching",
149 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
150 "verbosity level (0-2, default 1)"
151 ]
152
153 data Verbosity = Silent | Normal | Verbose
154 deriving (Show, Eq, Ord)
155
156 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
157 getVerbosity v [] = Right v
158 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
159 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
160 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
161 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
162 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
163 getVerbosity v (_ : fs) = getVerbosity v fs
164
165 deprecFlags :: [OptDescr Flag]
166 deprecFlags = [
167 -- put deprecated flags here
168 ]
169
170 ourCopyright :: String
171 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
172
173 usageHeader :: String -> String
174 usageHeader prog = substProg prog $
175 "Usage:\n" ++
176 " $p init {path}\n" ++
177 " Create and initialise a package database at the location {path}.\n" ++
178 " Packages can be registered in the new database using the register\n" ++
179 " command with --package-conf={path}. To use the new database with GHC,\n" ++
180 " use GHC's -package-conf flag.\n" ++
181 "\n" ++
182 " $p register {filename | -}\n" ++
183 " Register the package using the specified installed package\n" ++
184 " description. The syntax for the latter is given in the $p\n" ++
185 " documentation.\n" ++
186 "\n" ++
187 " $p update {filename | -}\n" ++
188 " Register the package, overwriting any other package with the\n" ++
189 " same name.\n" ++
190 "\n" ++
191 " $p unregister {pkg-id}\n" ++
192 " Unregister the specified package.\n" ++
193 "\n" ++
194 " $p expose {pkg-id}\n" ++
195 " Expose the specified package.\n" ++
196 "\n" ++
197 " $p hide {pkg-id}\n" ++
198 " Hide the specified package.\n" ++
199 "\n" ++
200 " $p list [pkg]\n" ++
201 " List registered packages in the global database, and also the\n" ++
202 " user database if --user is given. If a package name is given\n" ++
203 " all the registered versions will be listed in ascending order.\n" ++
204 " Accepts the --simple-output flag.\n" ++
205 "\n" ++
206 " $p dot\n" ++
207 " Generate a graph of the package dependencies in a form suitable\n" ++
208 " for input for the graphviz tools. For example, to generate a PDF" ++
209 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
210 "\n" ++
211 " $p find-module {module}\n" ++
212 " List registered packages exposing module {module} in the global\n" ++
213 " database, and also the user database if --user is given.\n" ++
214 " All the registered versions will be listed in ascending order.\n" ++
215 " Accepts the --simple-output flag.\n" ++
216 "\n" ++
217 " $p latest {pkg-id}\n" ++
218 " Prints the highest registered version of a package.\n" ++
219 "\n" ++
220 " $p check\n" ++
221 " Check the consistency of package depenencies and list broken packages.\n" ++
222 " Accepts the --simple-output flag.\n" ++
223 "\n" ++
224 " $p describe {pkg}\n" ++
225 " Give the registered description for the specified package. The\n" ++
226 " description is returned in precisely the syntax required by $p\n" ++
227 " register.\n" ++
228 "\n" ++
229 " $p field {pkg} {field}\n" ++
230 " Extract the specified field of the package description for the\n" ++
231 " specified package. Accepts comma-separated multiple fields.\n" ++
232 "\n" ++
233 " $p dump\n" ++
234 " Dump the registered description for every package. This is like\n" ++
235 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
236 " by tools that parse the results, rather than humans.\n" ++
237 "\n" ++
238 " Substring matching is supported for {module} in find-module and\n" ++
239 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
240 " open substring ends (prefix*, *suffix, *infix*).\n" ++
241 "\n" ++
242 " When asked to modify a database (register, unregister, update,\n"++
243 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
244 " default. Specifying --user causes it to act on the user database,\n"++
245 " or --package-conf can be used to act on another database\n"++
246 " entirely. When multiple of these options are given, the rightmost\n"++
247 " one is used as the database to act upon.\n"++
248 "\n"++
249 " Commands that query the package database (list, tree, latest, describe,\n"++
250 " field) operate on the list of databases specified by the flags\n"++
251 " --user, --global, and --package-conf. If none of these flags are\n"++
252 " given, the default is --global --user.\n"++
253 "\n" ++
254 " The following optional flags are also accepted:\n"
255
256 substProg :: String -> String -> String
257 substProg _ [] = []
258 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
259 substProg prog (c:xs) = c : substProg prog xs
260
261 -- -----------------------------------------------------------------------------
262 -- Do the business
263
264 data Force = NoForce | ForceFiles | ForceAll | CannotForce
265 deriving (Eq,Ord)
266
267 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
268
269 runit :: Verbosity -> [Flag] -> [String] -> IO ()
270 runit verbosity cli nonopts = do
271 installSignalHandlers -- catch ^C and clean up
272 prog <- getProgramName
273 let
274 force
275 | FlagForce `elem` cli = ForceAll
276 | FlagForceFiles `elem` cli = ForceFiles
277 | otherwise = NoForce
278 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
279 splitFields fields = unfoldr splitComma (',':fields)
280 where splitComma "" = Nothing
281 splitComma fs = Just $ break (==',') (tail fs)
282
283 substringCheck :: String -> Maybe (String -> Bool)
284 substringCheck "" = Nothing
285 substringCheck "*" = Just (const True)
286 substringCheck [_] = Nothing
287 substringCheck (h:t) =
288 case (h, init t, last t) of
289 ('*',s,'*') -> Just (isInfixOf (f s) . f)
290 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
291 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
292 _ -> Nothing
293 where f | FlagIgnoreCase `elem` cli = map toLower
294 | otherwise = id
295 #if defined(GLOB)
296 glob x | System.Info.os=="mingw32" = do
297 -- glob echoes its argument, after win32 filename globbing
298 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
299 txt <- hGetContents o
300 return (read txt)
301 glob x | otherwise = return [x]
302 #endif
303 --
304 -- first, parse the command
305 case nonopts of
306 #if defined(GLOB)
307 -- dummy command to demonstrate usage and permit testing
308 -- without messing things up; use glob to selectively enable
309 -- windows filename globbing for file parameters
310 -- register, update, FlagGlobalConfig, FlagConfig; others?
311 ["glob", filename] -> do
312 print filename
313 glob filename >>= print
314 #endif
315 ["init", filename] ->
316 initPackageDB filename verbosity cli
317 ["register", filename] ->
318 registerPackage filename verbosity cli auto_ghci_libs False force
319 ["update", filename] ->
320 registerPackage filename verbosity cli auto_ghci_libs True force
321 ["unregister", pkgid_str] -> do
322 pkgid <- readGlobPkgId pkgid_str
323 unregisterPackage pkgid verbosity cli force
324 ["expose", pkgid_str] -> do
325 pkgid <- readGlobPkgId pkgid_str
326 exposePackage pkgid verbosity cli force
327 ["hide", pkgid_str] -> do
328 pkgid <- readGlobPkgId pkgid_str
329 hidePackage pkgid verbosity cli force
330 ["list"] -> do
331 listPackages verbosity cli Nothing Nothing
332 ["list", pkgid_str] ->
333 case substringCheck pkgid_str of
334 Nothing -> do pkgid <- readGlobPkgId pkgid_str
335 listPackages verbosity cli (Just (Id pkgid)) Nothing
336 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
337 ["dot"] -> do
338 showPackageDot verbosity cli
339 ["find-module", moduleName] -> do
340 let match = maybe (==moduleName) id (substringCheck moduleName)
341 listPackages verbosity cli Nothing (Just match)
342 ["latest", pkgid_str] -> do
343 pkgid <- readGlobPkgId pkgid_str
344 latestPackage verbosity cli pkgid
345 ["describe", pkgid_str] ->
346 case substringCheck pkgid_str of
347 Nothing -> do pkgid <- readGlobPkgId pkgid_str
348 describePackage verbosity cli (Id pkgid)
349 Just m -> describePackage verbosity cli (Substring pkgid_str m)
350 ["field", pkgid_str, fields] ->
351 case substringCheck pkgid_str of
352 Nothing -> do pkgid <- readGlobPkgId pkgid_str
353 describeField verbosity cli (Id pkgid)
354 (splitFields fields)
355 Just m -> describeField verbosity cli (Substring pkgid_str m)
356 (splitFields fields)
357 ["check"] -> do
358 checkConsistency verbosity cli
359
360 ["dump"] -> do
361 dumpPackages verbosity cli
362
363 ["recache"] -> do
364 recache verbosity cli
365
366 [] -> do
367 die ("missing command\n" ++
368 usageInfo (usageHeader prog) flags)
369 (_cmd:_) -> do
370 die ("command-line syntax error\n" ++
371 usageInfo (usageHeader prog) flags)
372
373 parseCheck :: ReadP a a -> String -> String -> IO a
374 parseCheck parser str what =
375 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
376 [x] -> return x
377 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
378
379 readGlobPkgId :: String -> IO PackageIdentifier
380 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
381
382 parseGlobPackageId :: ReadP r PackageIdentifier
383 parseGlobPackageId =
384 parse
385 +++
386 (do n <- parse
387 _ <- string "-*"
388 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
389
390 -- globVersion means "all versions"
391 globVersion :: Version
392 globVersion = Version{ versionBranch=[], versionTags=["*"] }
393
394 -- -----------------------------------------------------------------------------
395 -- Package databases
396
397 -- Some commands operate on a single database:
398 -- register, unregister, expose, hide
399 -- however these commands also check the union of the available databases
400 -- in order to check consistency. For example, register will check that
401 -- dependencies exist before registering a package.
402 --
403 -- Some commands operate on multiple databases, with overlapping semantics:
404 -- list, describe, field
405
406 data PackageDB
407 = PackageDB { location :: FilePath,
408 packages :: [InstalledPackageInfo] }
409
410 type PackageDBStack = [PackageDB]
411 -- A stack of package databases. Convention: head is the topmost
412 -- in the stack.
413
414 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
415 allPackagesInStack = concatMap packages
416
417 getPkgDatabases :: Verbosity
418 -> Bool -- we are modifying, not reading
419 -> Bool -- read caches, if available
420 -> [Flag]
421 -> IO (PackageDBStack,
422 -- the real package DB stack: [global,user] ++
423 -- DBs specified on the command line with -f.
424 Maybe FilePath,
425 -- which one to modify, if any
426 PackageDBStack)
427 -- the package DBs specified on the command
428 -- line, or [global,user] otherwise. This
429 -- is used as the list of package DBs for
430 -- commands that just read the DB, such as 'list'.
431
432 getPkgDatabases verbosity modify use_cache my_flags = do
433 -- first we determine the location of the global package config. On Windows,
434 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
435 -- location is passed to the binary using the --global-config flag by the
436 -- wrapper script.
437 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
438 global_conf <-
439 case [ f | FlagGlobalConfig f <- my_flags ] of
440 [] -> do mb_dir <- getLibDir
441 case mb_dir of
442 Nothing -> die err_msg
443 Just dir -> do
444 r <- lookForPackageDBIn dir
445 case r of
446 Nothing -> die ("Can't find package database in " ++ dir)
447 Just path -> return path
448 fs -> return (last fs)
449
450 let no_user_db = FlagNoUserDb `elem` my_flags
451
452 -- get the location of the user package database, and create it if necessary
453 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
454 e_appdir <- try $ getAppUserDataDirectory "ghc"
455
456 mb_user_conf <-
457 if no_user_db then return Nothing else
458 case e_appdir of
459 Left _ -> return Nothing
460 Right appdir -> do
461 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
462 dir = appdir </> subdir
463 r <- lookForPackageDBIn dir
464 case r of
465 Nothing -> return (Just (dir </> "package.conf.d", False))
466 Just f -> return (Just (f, True))
467
468 -- If the user database doesn't exist, and this command isn't a
469 -- "modify" command, then we won't attempt to create or use it.
470 let sys_databases
471 | Just (user_conf,user_exists) <- mb_user_conf,
472 modify || user_exists = [user_conf, global_conf]
473 | otherwise = [global_conf]
474
475 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
476 let env_stack =
477 case e_pkg_path of
478 Left _ -> sys_databases
479 Right path
480 | last cs == "" -> init cs ++ sys_databases
481 | otherwise -> cs
482 where cs = parseSearchPath path
483
484 -- The "global" database is always the one at the bottom of the stack.
485 -- This is the database we modify by default.
486 virt_global_conf = last env_stack
487
488 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
489 where is_db_flag FlagUser
490 | Just (user_conf, _user_exists) <- mb_user_conf
491 = Just user_conf
492 is_db_flag FlagGlobal = Just virt_global_conf
493 is_db_flag (FlagConfig f) = Just f
494 is_db_flag _ = Nothing
495
496 let flag_db_names | null db_flags = env_stack
497 | otherwise = reverse (nub db_flags)
498
499 -- For a "modify" command, treat all the databases as
500 -- a stack, where we are modifying the top one, but it
501 -- can refer to packages in databases further down the
502 -- stack.
503
504 -- -f flags on the command line add to the database
505 -- stack, unless any of them are present in the stack
506 -- already.
507 let final_stack = filter (`notElem` env_stack)
508 [ f | FlagConfig f <- reverse my_flags ]
509 ++ env_stack
510
511 -- the database we actually modify is the one mentioned
512 -- rightmost on the command-line.
513 let to_modify
514 | not modify = Nothing
515 | null db_flags = Just virt_global_conf
516 | otherwise = Just (last db_flags)
517
518 db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
519
520 let flag_db_stack = [ db | db_name <- flag_db_names,
521 db <- db_stack, location db == db_name ]
522
523 return (db_stack, to_modify, flag_db_stack)
524
525
526 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
527 lookForPackageDBIn dir = do
528 let path_dir = dir </> "package.conf.d"
529 exists_dir <- doesDirectoryExist path_dir
530 if exists_dir then return (Just path_dir) else do
531 let path_file = dir </> "package.conf"
532 exists_file <- doesFileExist path_file
533 if exists_file then return (Just path_file) else return Nothing
534
535 readParseDatabase :: Verbosity
536 -> Maybe (FilePath,Bool)
537 -> Bool -- use cache
538 -> FilePath
539 -> IO PackageDB
540
541 readParseDatabase verbosity mb_user_conf use_cache path
542 -- the user database (only) is allowed to be non-existent
543 | Just (user_conf,False) <- mb_user_conf, path == user_conf
544 = return PackageDB { location = path, packages = [] }
545 | otherwise
546 = do e <- try $ getDirectoryContents path
547 case e of
548 Left _ -> do
549 pkgs <- parseMultiPackageConf verbosity path
550 return PackageDB{ location = path, packages = pkgs }
551 Right fs
552 | not use_cache -> ignore_cache
553 | otherwise -> do
554 let cache = path </> cachefilename
555 tdir <- getModificationTime path
556 e_tcache <- try $ getModificationTime cache
557 case e_tcache of
558 Left ex -> do
559 when (verbosity > Normal) $
560 putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
561 ignore_cache
562 Right tcache
563 | tcache >= tdir -> do
564 when (verbosity > Normal) $
565 putStrLn ("using cache: " ++ cache)
566 pkgs <- myReadBinPackageDB cache
567 let pkgs' = map convertPackageInfoIn pkgs
568 return PackageDB { location = path, packages = pkgs' }
569 | otherwise -> do
570 when (verbosity >= Normal) $ do
571 putStrLn ("WARNING: cache is out of date: " ++ cache)
572 putStrLn " use 'ghc-pkg recache' to fix."
573 ignore_cache
574 where
575 ignore_cache = do
576 let confs = filter (".conf" `isSuffixOf`) fs
577 pkgs <- mapM (parseSingletonPackageConf verbosity) $
578 map (path </>) confs
579 return PackageDB { location = path, packages = pkgs }
580
581 -- read the package.cache file strictly, to work around a problem with
582 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
583 -- after it has been completely read, leading to a sharing violation
584 -- later.
585 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
586 myReadBinPackageDB filepath = do
587 h <- openBinaryFile filepath ReadMode
588 sz <- hFileSize h
589 b <- B.hGet h (fromIntegral sz)
590 hClose h
591 return $ Bin.runGet Bin.get b
592
593 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
594 parseMultiPackageConf verbosity file = do
595 when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
596 str <- readFile file
597 let pkgs = map convertPackageInfoIn $ read str
598 Exception.evaluate pkgs
599 `catchError` \e->
600 die ("error while parsing " ++ file ++ ": " ++ show e)
601
602 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
603 parseSingletonPackageConf verbosity file = do
604 when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
605 readFile file >>= parsePackageInfo
606
607 cachefilename :: FilePath
608 cachefilename = "package.cache"
609
610 -- -----------------------------------------------------------------------------
611 -- Creating a new package DB
612
613 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
614 initPackageDB filename verbosity _flags = do
615 let eexist = die ("cannot create: " ++ filename ++ " already exists")
616 b1 <- doesFileExist filename
617 when b1 eexist
618 b2 <- doesDirectoryExist filename
619 when b2 eexist
620 changeDB verbosity [] PackageDB{ location = filename, packages = [] }
621
622 -- -----------------------------------------------------------------------------
623 -- Registering
624
625 registerPackage :: FilePath
626 -> Verbosity
627 -> [Flag]
628 -> Bool -- auto_ghci_libs
629 -> Bool -- update
630 -> Force
631 -> IO ()
632 registerPackage input verbosity my_flags auto_ghci_libs update force = do
633 (db_stack, Just to_modify, _flag_dbs) <-
634 getPkgDatabases verbosity True True my_flags
635
636 let
637 db_to_operate_on = my_head "register" $
638 filter ((== to_modify).location) db_stack
639 --
640 s <-
641 case input of
642 "-" -> do
643 when (verbosity >= Normal) $
644 putStr "Reading package info from stdin ... "
645 getContents
646 f -> do
647 when (verbosity >= Normal) $
648 putStr ("Reading package info from " ++ show f ++ " ... ")
649 readFile f
650
651 expanded <- expandEnvVars s force
652
653 pkg <- parsePackageInfo expanded
654 when (verbosity >= Normal) $
655 putStrLn "done."
656
657 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
658 -- truncate the stack for validation, because we don't allow
659 -- packages lower in the stack to refer to those higher up.
660 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
661 let
662 removes = [ RemovePackage p
663 | p <- packages db_to_operate_on,
664 sourcePackageId p == sourcePackageId pkg ]
665 --
666 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
667
668 parsePackageInfo
669 :: String
670 -> IO InstalledPackageInfo
671 parsePackageInfo str =
672 case parseInstalledPackageInfo str of
673 ParseOk _warns ok -> return ok
674 ParseFailed err -> case locatedErrorMsg err of
675 (Nothing, s) -> die s
676 (Just l, s) -> die (show l ++ ": " ++ s)
677
678 -- -----------------------------------------------------------------------------
679 -- Making changes to a package database
680
681 data DBOp = RemovePackage InstalledPackageInfo
682 | AddPackage InstalledPackageInfo
683 | ModifyPackage InstalledPackageInfo
684
685 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
686 changeDB verbosity cmds db = do
687 let db' = updateInternalDB db cmds
688 isfile <- doesFileExist (location db)
689 if isfile
690 then writeNewConfig verbosity (location db') (packages db')
691 else do
692 createDirectoryIfMissing True (location db)
693 changeDBDir verbosity cmds db'
694
695 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
696 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
697 where
698 do_cmd pkgs (RemovePackage p) =
699 filter ((/= installedPackageId p) . installedPackageId) pkgs
700 do_cmd pkgs (AddPackage p) = p : pkgs
701 do_cmd pkgs (ModifyPackage p) =
702 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
703
704
705 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
706 changeDBDir verbosity cmds db = do
707 mapM_ do_cmd cmds
708 updateDBCache verbosity db
709 where
710 do_cmd (RemovePackage p) = do
711 let file = location db </> display (installedPackageId p) <.> "conf"
712 when (verbosity > Normal) $ putStrLn ("removing " ++ file)
713 removeFile file
714 do_cmd (AddPackage p) = do
715 let file = location db </> display (installedPackageId p) <.> "conf"
716 when (verbosity > Normal) $ putStrLn ("writing " ++ file)
717 writeFileAtomic file (showInstalledPackageInfo p)
718 do_cmd (ModifyPackage p) =
719 do_cmd (AddPackage p)
720
721 updateDBCache :: Verbosity -> PackageDB -> IO ()
722 updateDBCache verbosity db = do
723 let filename = location db </> cachefilename
724 when (verbosity > Normal) $
725 putStrLn ("writing cache " ++ filename)
726 writeBinPackageDB filename (map convertPackageInfoOut (packages db))
727 `catch` \e ->
728 if isPermissionError e
729 then die (filename ++ ": you don't have permission to modify this file")
730 else ioError e
731
732 -- -----------------------------------------------------------------------------
733 -- Exposing, Hiding, Unregistering are all similar
734
735 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
736 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
737
738 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
739 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
740
741 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
742 unregisterPackage = modifyPackage RemovePackage
743
744 modifyPackage
745 :: (InstalledPackageInfo -> DBOp)
746 -> PackageIdentifier
747 -> Verbosity
748 -> [Flag]
749 -> Force
750 -> IO ()
751 modifyPackage fn pkgid verbosity my_flags force = do
752 (db_stack, Just _to_modify, _flag_dbs) <-
753 getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
754
755 (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
756 let
757 db_name = location db
758 pkgs = packages db
759
760 pids = map sourcePackageId ps
761
762 cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
763 new_db = updateInternalDB db cmds
764
765 old_broken = brokenPackages (allPackagesInStack db_stack)
766 rest_of_stack = filter ((/= db_name) . location) db_stack
767 new_stack = new_db : rest_of_stack
768 new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
769 newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
770 --
771 when (not (null newly_broken)) $
772 dieOrForceAll force ("unregistering " ++ display pkgid ++
773 " would break the following packages: "
774 ++ unwords (map display newly_broken))
775
776 changeDB verbosity cmds db
777
778 recache :: Verbosity -> [Flag] -> IO ()
779 recache verbosity my_flags = do
780 (db_stack, Just to_modify, _flag_dbs) <-
781 getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
782 let
783 db_to_operate_on = my_head "recache" $
784 filter ((== to_modify).location) db_stack
785 --
786 changeDB verbosity [] db_to_operate_on
787
788 -- -----------------------------------------------------------------------------
789 -- Listing packages
790
791 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
792 -> Maybe (String->Bool)
793 -> IO ()
794 listPackages verbosity my_flags mPackageName mModuleName = do
795 let simple_output = FlagSimpleOutput `elem` my_flags
796 (db_stack, _, flag_db_stack) <-
797 getPkgDatabases verbosity False True{-use cache-} my_flags
798
799 let db_stack_filtered -- if a package is given, filter out all other packages
800 | Just this <- mPackageName =
801 [ db{ packages = filter (this `matchesPkg`) (packages db) }
802 | db <- flag_db_stack ]
803 | Just match <- mModuleName = -- packages which expose mModuleName
804 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
805 | db <- flag_db_stack ]
806 | otherwise = flag_db_stack
807
808 db_stack_sorted
809 = [ db{ packages = sort_pkgs (packages db) }
810 | db <- db_stack_filtered ]
811 where sort_pkgs = sortBy cmpPkgIds
812 cmpPkgIds pkg1 pkg2 =
813 case pkgName p1 `compare` pkgName p2 of
814 LT -> LT
815 GT -> GT
816 EQ -> pkgVersion p1 `compare` pkgVersion p2
817 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
818
819 stack = reverse db_stack_sorted
820
821 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
822
823 pkg_map = allPackagesInStack db_stack
824 broken = map sourcePackageId (brokenPackages pkg_map)
825
826 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
827 hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
828 where
829 pp_pkgs = map pp_pkg pkg_confs
830 pp_pkg p
831 | sourcePackageId p `elem` broken = printf "{%s}" doc
832 | exposed p = doc
833 | otherwise = printf "(%s)" doc
834 where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
835 | otherwise = pkg
836 where
837 InstalledPackageId ipid = installedPackageId p
838 pkg = display (sourcePackageId p)
839
840 show_simple = simplePackageList my_flags . allPackagesInStack
841
842 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
843 prog <- getProgramName
844 putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
845
846 if simple_output then show_simple stack else do
847
848 #if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
849 mapM_ show_normal stack
850 #else
851 let
852 show_colour withF db =
853 mconcat $ map (<#> termText "\n") $
854 (termText (location db) :
855 map (termText " " <#>) (map pp_pkg (packages db)))
856 where
857 pp_pkg p
858 | sourcePackageId p `elem` broken = withF Red doc
859 | exposed p = doc
860 | otherwise = withF Blue doc
861 where doc | verbosity >= Verbose
862 = termText (printf "%s (%s)" pkg ipid)
863 | otherwise
864 = termText pkg
865 where
866 InstalledPackageId ipid = installedPackageId p
867 pkg = display (sourcePackageId p)
868
869 is_tty <- hIsTerminalDevice stdout
870 if not is_tty
871 then mapM_ show_normal stack
872 else do tty <- Terminfo.setupTermFromEnv
873 case Terminfo.getCapability tty withForegroundColor of
874 Nothing -> mapM_ show_normal stack
875 Just w -> runTermOutput tty $ mconcat $
876 map (show_colour w) stack
877 #endif
878
879 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
880 simplePackageList my_flags pkgs = do
881 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
882 else display
883 strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
884 when (not (null pkgs)) $
885 hPutStrLn stdout $ concat $ intersperse " " strs
886
887 showPackageDot :: Verbosity -> [Flag] -> IO ()
888 showPackageDot verbosity myflags = do
889 (_, _, flag_db_stack) <-
890 getPkgDatabases verbosity False True{-use cache-} myflags
891
892 let all_pkgs = allPackagesInStack flag_db_stack
893 ipix = PackageIndex.fromList all_pkgs
894
895 putStrLn "digraph {"
896 let quote s = '"':s ++ "\""
897 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
898 | p <- all_pkgs,
899 let from = display (sourcePackageId p),
900 depid <- depends p,
901 Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
902 let to = display (sourcePackageId dep)
903 ]
904 putStrLn "}"
905
906 -- -----------------------------------------------------------------------------
907 -- Prints the highest (hidden or exposed) version of a package
908
909 latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
910 latestPackage verbosity my_flags pkgid = do
911 (_, _, flag_db_stack) <-
912 getPkgDatabases verbosity False True{-use cache-} my_flags
913
914 ps <- findPackages flag_db_stack (Id pkgid)
915 show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
916 where
917 show_pkg [] = die "no matches"
918 show_pkg pids = hPutStrLn stdout (display (last pids))
919
920 -- -----------------------------------------------------------------------------
921 -- Describe
922
923 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
924 describePackage verbosity my_flags pkgarg = do
925 (_, _, flag_db_stack) <-
926 getPkgDatabases verbosity False True{-use cache-} my_flags
927 ps <- findPackages flag_db_stack pkgarg
928 doDump ps
929
930 dumpPackages :: Verbosity -> [Flag] -> IO ()
931 dumpPackages verbosity my_flags = do
932 (_, _, flag_db_stack) <-
933 getPkgDatabases verbosity False True{-use cache-} my_flags
934 doDump (allPackagesInStack flag_db_stack)
935
936 doDump :: [InstalledPackageInfo] -> IO ()
937 doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
938
939 -- PackageId is can have globVersion for the version
940 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
941 findPackages db_stack pkgarg
942 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
943
944 findPackagesByDB :: PackageDBStack -> PackageArg
945 -> IO [(PackageDB, [InstalledPackageInfo])]
946 findPackagesByDB db_stack pkgarg
947 = case [ (db, matched)
948 | db <- db_stack,
949 let matched = filter (pkgarg `matchesPkg`) (packages db),
950 not (null matched) ] of
951 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
952 ps -> return ps
953 where
954 pkg_msg (Id pkgid) = display pkgid
955 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
956
957 matches :: PackageIdentifier -> PackageIdentifier -> Bool
958 pid `matches` pid'
959 = (pkgName pid == pkgName pid')
960 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
961
962 realVersion :: PackageIdentifier -> Bool
963 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
964 -- when versionBranch == [], this is a glob
965
966 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
967 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
968 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
969
970 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
971 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
972
973 -- -----------------------------------------------------------------------------
974 -- Field
975
976 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
977 describeField verbosity my_flags pkgarg fields = do
978 (_, _, flag_db_stack) <-
979 getPkgDatabases verbosity False True{-use cache-} my_flags
980 fns <- toFields fields
981 ps <- findPackages flag_db_stack pkgarg
982 let top_dir = takeDirectory (location (last flag_db_stack))
983 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
984 where toFields [] = return []
985 toFields (f:fs) = case toField f of
986 Nothing -> die ("unknown field: " ++ f)
987 Just fn -> do fns <- toFields fs
988 return (fn:fns)
989 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
990
991 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
992 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
993 -- with the current topdir (obtained from the -B option).
994 mungePackagePaths top_dir ps = map munge_pkg ps
995 where
996 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
997 includeDirs = munge_paths (includeDirs p),
998 libraryDirs = munge_paths (libraryDirs p),
999 frameworkDirs = munge_paths (frameworkDirs p),
1000 haddockInterfaces = munge_paths (haddockInterfaces p),
1001 haddockHTMLs = munge_paths (haddockHTMLs p)
1002 }
1003
1004 munge_paths = map munge_path
1005
1006 munge_path p
1007 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1008 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1009 | otherwise = p
1010
1011 toHttpPath p = "file:///" ++ p
1012
1013 maybePrefixMatch :: String -> String -> Maybe String
1014 maybePrefixMatch [] rest = Just rest
1015 maybePrefixMatch (_:_) [] = Nothing
1016 maybePrefixMatch (p:pat) (r:rest)
1017 | p == r = maybePrefixMatch pat rest
1018 | otherwise = Nothing
1019
1020 toField :: String -> Maybe (InstalledPackageInfo -> String)
1021 -- backwards compatibility:
1022 toField "import_dirs" = Just $ strList . importDirs
1023 toField "source_dirs" = Just $ strList . importDirs
1024 toField "library_dirs" = Just $ strList . libraryDirs
1025 toField "hs_libraries" = Just $ strList . hsLibraries
1026 toField "extra_libraries" = Just $ strList . extraLibraries
1027 toField "include_dirs" = Just $ strList . includeDirs
1028 toField "c_includes" = Just $ strList . includes
1029 toField "package_deps" = Just $ strList . map display. depends
1030 toField "extra_cc_opts" = Just $ strList . ccOptions
1031 toField "extra_ld_opts" = Just $ strList . ldOptions
1032 toField "framework_dirs" = Just $ strList . frameworkDirs
1033 toField "extra_frameworks"= Just $ strList . frameworks
1034 toField s = showInstalledPackageInfoField s
1035
1036 strList :: [String] -> String
1037 strList = show
1038
1039
1040 -- -----------------------------------------------------------------------------
1041 -- Check: Check consistency of installed packages
1042
1043 checkConsistency :: Verbosity -> [Flag] -> IO ()
1044 checkConsistency verbosity my_flags = do
1045 (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1046 -- check behaves like modify for the purposes of deciding which
1047 -- databases to use, because ordering is important.
1048
1049 let simple_output = FlagSimpleOutput `elem` my_flags
1050
1051 let pkgs = allPackagesInStack db_stack
1052
1053 checkPackage p = do
1054 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
1055 if null es
1056 then return []
1057 else do
1058 when (not simple_output) $ do
1059 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1060 _ <- reportValidateErrors es " " Nothing
1061 return ()
1062 return [p]
1063
1064 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1065
1066 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1067 where not_in p = sourcePackageId p `notElem` all_ps
1068 all_ps = map sourcePackageId pkgs1
1069
1070 let not_broken_pkgs = filterOut broken_pkgs pkgs
1071 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1072 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1073
1074 when (not (null all_broken_pkgs)) $ do
1075 if simple_output
1076 then simplePackageList my_flags all_broken_pkgs
1077 else do
1078 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1079 "listed above, or because they depend on a broken package.")
1080 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1081
1082 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1083
1084
1085 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1086 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1087 closure pkgs db_stack = go pkgs db_stack
1088 where
1089 go avail not_avail =
1090 case partition (depsAvailable avail) not_avail of
1091 ([], not_avail') -> (avail, not_avail')
1092 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1093
1094 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1095 -> Bool
1096 depsAvailable pkgs_ok pkg = null dangling
1097 where dangling = filter (`notElem` pids) (depends pkg)
1098 pids = map installedPackageId pkgs_ok
1099
1100 -- we want mutually recursive groups of package to show up
1101 -- as broken. (#1750)
1102
1103 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1104 brokenPackages pkgs = snd (closure [] pkgs)
1105
1106 -- -----------------------------------------------------------------------------
1107 -- Manipulating package.conf files
1108
1109 type InstalledPackageInfoString = InstalledPackageInfo_ String
1110
1111 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1112 convertPackageInfoOut
1113 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1114 hiddenModules = h })) =
1115 pkgconf{ exposedModules = map display e,
1116 hiddenModules = map display h }
1117
1118 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1119 convertPackageInfoIn
1120 (pkgconf@(InstalledPackageInfo { exposedModules = e,
1121 hiddenModules = h })) =
1122 pkgconf{ exposedModules = map convert e,
1123 hiddenModules = map convert h }
1124 where convert = fromJust . simpleParse
1125
1126 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1127 writeNewConfig verbosity filename ipis = do
1128 when (verbosity >= Normal) $
1129 hPutStr stdout "Writing new package config file... "
1130 createDirectoryIfMissing True $ takeDirectory filename
1131 let shown = concat $ intersperse ",\n "
1132 $ map (show . convertPackageInfoOut) ipis
1133 fileContents = "[" ++ shown ++ "\n]"
1134 writeFileAtomic filename fileContents
1135 `catch` \e ->
1136 if isPermissionError e
1137 then die (filename ++ ": you don't have permission to modify this file")
1138 else ioError e
1139 when (verbosity >= Normal) $
1140 hPutStrLn stdout "done."
1141
1142 -----------------------------------------------------------------------------
1143 -- Sanity-check a new package config, and automatically build GHCi libs
1144 -- if requested.
1145
1146 type ValidateError = (Force,String)
1147
1148 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
1149
1150 instance Monad Validate where
1151 return a = V $ return (a, [])
1152 m >>= k = V $ do
1153 (a, es) <- runValidate m
1154 (b, es') <- runValidate (k a)
1155 return (b,es++es')
1156
1157 verror :: Force -> String -> Validate ()
1158 verror f s = V (return ((),[(f,s)]))
1159
1160 liftIO :: IO a -> Validate a
1161 liftIO k = V (k >>= \a -> return (a,[]))
1162
1163 -- returns False if we should die
1164 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
1165 reportValidateErrors es prefix mb_force = do
1166 oks <- mapM report es
1167 return (and oks)
1168 where
1169 report (f,s)
1170 | Just force <- mb_force
1171 = if (force >= f)
1172 then do reportError (prefix ++ s ++ " (ignoring)")
1173 return True
1174 else if f < CannotForce
1175 then do reportError (prefix ++ s ++ " (use --force to override)")
1176 return False
1177 else do reportError err
1178 return False
1179 | otherwise = do reportError err
1180 return False
1181 where
1182 err = prefix ++ s
1183
1184 validatePackageConfig :: InstalledPackageInfo
1185 -> PackageDBStack
1186 -> Bool -- auto-ghc-libs
1187 -> Bool -- update, or check
1188 -> Force
1189 -> IO ()
1190 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1191 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1192 ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
1193 when (not ok) $ exitWith (ExitFailure 1)
1194
1195 checkPackageConfig :: InstalledPackageInfo
1196 -> PackageDBStack
1197 -> Bool -- auto-ghc-libs
1198 -> Bool -- update, or check
1199 -> Validate ()
1200 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1201 checkInstalledPackageId pkg db_stack update
1202 checkPackageId pkg
1203 checkDuplicates db_stack pkg update
1204 mapM_ (checkDep db_stack) (depends pkg)
1205 checkDuplicateDepends (depends pkg)
1206 mapM_ (checkDir "import-dirs") (importDirs pkg)
1207 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
1208 mapM_ (checkDir "include-dirs") (includeDirs pkg)
1209 checkModules pkg
1210 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1211 -- ToDo: check these somehow?
1212 -- extra_libraries :: [String],
1213 -- c_includes :: [String],
1214
1215 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1216 -> Validate ()
1217 checkInstalledPackageId ipi db_stack update = do
1218 let ipid@(InstalledPackageId str) = installedPackageId ipi
1219 when (null str) $ verror CannotForce "missing id field"
1220 let dups = [ p | p <- allPackagesInStack db_stack,
1221 installedPackageId p == ipid ]
1222 when (not update && not (null dups)) $
1223 verror CannotForce $
1224 "package(s) with this id already exist: " ++
1225 unwords (map (display.packageId) dups)
1226
1227 -- When the package name and version are put together, sometimes we can
1228 -- end up with a package id that cannot be parsed. This will lead to
1229 -- difficulties when the user wants to refer to the package later, so
1230 -- we check that the package id can be parsed properly here.
1231 checkPackageId :: InstalledPackageInfo -> Validate ()
1232 checkPackageId ipi =
1233 let str = display (sourcePackageId ipi) in
1234 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1235 [_] -> return ()
1236 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1237 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1238
1239 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1240 checkDuplicates db_stack pkg update = do
1241 let
1242 pkgid = sourcePackageId pkg
1243 pkgs = packages (head db_stack)
1244 --
1245 -- Check whether this package id already exists in this DB
1246 --
1247 when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1248 verror CannotForce $
1249 "package " ++ display pkgid ++ " is already installed"
1250
1251 let
1252 uncasep = map toLower . display
1253 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1254
1255 when (not update && not (null dups)) $ verror ForceAll $
1256 "Package names may be treated case-insensitively in the future.\n"++
1257 "Package " ++ display pkgid ++
1258 " overlaps with: " ++ unwords (map display dups)
1259
1260
1261 checkDir :: String -> String -> Validate ()
1262 checkDir thisfield d
1263 | "$topdir" `isPrefixOf` d = return ()
1264 | "$httptopdir" `isPrefixOf` d = return ()
1265 -- can't check these, because we don't know what $(http)topdir is
1266 | otherwise = do
1267 there <- liftIO $ doesDirectoryExist d
1268 when (not there) $
1269 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1270
1271 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1272 checkDep db_stack pkgid
1273 | pkgid `elem` pkgids = return ()
1274 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1275 ++ "\" doesn't exist")
1276 where
1277 all_pkgs = allPackagesInStack db_stack
1278 pkgids = map installedPackageId all_pkgs
1279
1280 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1281 checkDuplicateDepends deps
1282 | null dups = return ()
1283 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1284 unwords (map display dups))
1285 where
1286 dups = [ p | (p:_:_) <- group (sort deps) ]
1287
1288 checkHSLib :: [String] -> Bool -> String -> Validate ()
1289 checkHSLib dirs auto_ghci_libs lib = do
1290 let batch_lib_file = "lib" ++ lib ++ ".a"
1291 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1292 case m of
1293 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1294 " on library path")
1295 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1296
1297 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1298 doesFileExistOnPath file path = go path
1299 where go [] = return Nothing
1300 go (p:ps) = do b <- doesFileExistIn file p
1301 if b then return (Just p) else go ps
1302
1303 doesFileExistIn :: String -> String -> IO Bool
1304 doesFileExistIn lib d
1305 | "$topdir" `isPrefixOf` d = return True
1306 | "$httptopdir" `isPrefixOf` d = return True
1307 | otherwise = doesFileExist (d </> lib)
1308
1309 checkModules :: InstalledPackageInfo -> Validate ()
1310 checkModules pkg = do
1311 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1312 where
1313 findModule modl = do
1314 -- there's no .hi file for GHC.Prim
1315 if modl == fromString "GHC.Prim" then return () else do
1316 let file = toFilePath modl <.> "hi"
1317 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1318 when (isNothing m) $
1319 verror ForceFiles ("file " ++ file ++ " is missing")
1320
1321 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1322 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1323 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1324 | otherwise = do
1325 m <- doesFileExistOnPath ghci_lib_file dirs
1326 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1327 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1328 where
1329 ghci_lib_file = lib <.> "o"
1330
1331 -- automatically build the GHCi version of a batch lib,
1332 -- using ld --whole-archive.
1333
1334 autoBuildGHCiLib :: String -> String -> String -> IO ()
1335 autoBuildGHCiLib dir batch_file ghci_file = do
1336 let ghci_lib_file = dir ++ '/':ghci_file
1337 batch_lib_file = dir ++ '/':batch_file
1338 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1339 #if defined(darwin_HOST_OS)
1340 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1341 #elif defined(mingw32_HOST_OS)
1342 execDir <- getLibDir
1343 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1344 #else
1345 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1346 #endif
1347 when (r /= ExitSuccess) $ exitWith r
1348 hPutStrLn stderr (" done.")
1349
1350 -- -----------------------------------------------------------------------------
1351 -- Searching for modules
1352
1353 #if not_yet
1354
1355 findModules :: [FilePath] -> IO [String]
1356 findModules paths =
1357 mms <- mapM searchDir paths
1358 return (concat mms)
1359
1360 searchDir path prefix = do
1361 fs <- getDirectoryEntries path `catch` \_ -> return []
1362 searchEntries path prefix fs
1363
1364 searchEntries path prefix [] = return []
1365 searchEntries path prefix (f:fs)
1366 | looks_like_a_module = do
1367 ms <- searchEntries path prefix fs
1368 return (prefix `joinModule` f : ms)
1369 | looks_like_a_component = do
1370 ms <- searchDir (path </> f) (prefix `joinModule` f)
1371 ms' <- searchEntries path prefix fs
1372 return (ms ++ ms')
1373 | otherwise
1374 searchEntries path prefix fs
1375
1376 where
1377 (base,suffix) = splitFileExt f
1378 looks_like_a_module =
1379 suffix `elem` haskell_suffixes &&
1380 all okInModuleName base
1381 looks_like_a_component =
1382 null suffix && all okInModuleName base
1383
1384 okInModuleName c
1385
1386 #endif
1387
1388 -- ---------------------------------------------------------------------------
1389 -- expanding environment variables in the package configuration
1390
1391 expandEnvVars :: String -> Force -> IO String
1392 expandEnvVars str0 force = go str0 ""
1393 where
1394 go "" acc = return $! reverse acc
1395 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1396 = do value <- lookupEnvVar var
1397 go rest (reverse value ++ acc)
1398 where close c = c == '}' || c == '\n' -- don't span newlines
1399 go (c:str) acc
1400 = go str (c:acc)
1401
1402 lookupEnvVar :: String -> IO String
1403 lookupEnvVar nm =
1404 catch (System.Environment.getEnv nm)
1405 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1406 show nm)
1407 return "")
1408
1409 -----------------------------------------------------------------------------
1410
1411 getProgramName :: IO String
1412 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1413 where str `withoutSuffix` suff
1414 | suff `isSuffixOf` str = take (length str - length suff) str
1415 | otherwise = str
1416
1417 bye :: String -> IO a
1418 bye s = putStr s >> exitWith ExitSuccess
1419
1420 die :: String -> IO a
1421 die = dieWith 1
1422
1423 dieWith :: Int -> String -> IO a
1424 dieWith ec s = do
1425 hFlush stdout
1426 prog <- getProgramName
1427 hPutStrLn stderr (prog ++ ": " ++ s)
1428 exitWith (ExitFailure ec)
1429
1430 dieOrForceAll :: Force -> String -> IO ()
1431 dieOrForceAll ForceAll s = ignoreError s
1432 dieOrForceAll _other s = dieForcible s
1433
1434 ignoreError :: String -> IO ()
1435 ignoreError s = reportError (s ++ " (ignoring)")
1436
1437 reportError :: String -> IO ()
1438 reportError s = do hFlush stdout; hPutStrLn stderr s
1439
1440 dieForcible :: String -> IO ()
1441 dieForcible s = die (s ++ " (use --force to override)")
1442
1443 my_head :: String -> [a] -> a
1444 my_head s [] = error s
1445 my_head _ (x : _) = x
1446
1447 -----------------------------------------
1448 -- Cut and pasted from ghc/compiler/main/SysTools
1449
1450 #if defined(mingw32_HOST_OS)
1451 subst :: Char -> Char -> String -> String
1452 subst a b ls = map (\ x -> if x == a then b else x) ls
1453
1454 unDosifyPath :: FilePath -> FilePath
1455 unDosifyPath xs = subst '\\' '/' xs
1456
1457 getLibDir :: IO (Maybe String)
1458 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1459
1460 -- (getExecDir cmd) returns the directory in which the current
1461 -- executable, which should be called 'cmd', is running
1462 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1463 -- you'll get "/a/b/c" back as the result
1464 getExecDir :: String -> IO (Maybe String)
1465 getExecDir cmd =
1466 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1467 where initN n = reverse . drop n . reverse
1468 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1469
1470 getExecPath :: IO (Maybe String)
1471 getExecPath =
1472 allocaArray len $ \buf -> do
1473 ret <- getModuleFileName nullPtr buf len
1474 if ret == 0 then return Nothing
1475 else liftM Just $ peekCString buf
1476 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1477
1478 foreign import stdcall unsafe "GetModuleFileNameA"
1479 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1480
1481 #else
1482 getLibDir :: IO (Maybe String)
1483 getLibDir = return Nothing
1484 #endif
1485
1486 -----------------------------------------
1487 -- Adapted from ghc/compiler/utils/Panic
1488
1489 installSignalHandlers :: IO ()
1490 installSignalHandlers = do
1491 threadid <- myThreadId
1492 let
1493 interrupt = Exception.throwTo threadid
1494 (Exception.ErrorCall "interrupted")
1495 --
1496 #if !defined(mingw32_HOST_OS)
1497 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1498 _ <- installHandler sigINT (Catch interrupt) Nothing
1499 return ()
1500 #elif __GLASGOW_HASKELL__ >= 603
1501 -- GHC 6.3+ has support for console events on Windows
1502 -- NOTE: running GHCi under a bash shell for some reason requires
1503 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1504 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1505 -- why --SDM 17/12/2004
1506 let sig_handler ControlC = interrupt
1507 sig_handler Break = interrupt
1508 sig_handler _ = return ()
1509
1510 _ <- installHandler (Catch sig_handler)
1511 return ()
1512 #else
1513 return () -- nothing
1514 #endif
1515
1516 #if __GLASGOW_HASKELL__ <= 604
1517 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1518 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1519 #endif
1520
1521 #if mingw32_HOST_OS || mingw32_TARGET_OS
1522 throwIOIO :: Exception.IOException -> IO a
1523 throwIOIO = Exception.throwIO
1524
1525 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1526 catchIO = Exception.catch
1527 #endif
1528
1529 catchError :: IO a -> (String -> IO a) -> IO a
1530 catchError io handler = io `Exception.catch` handler'
1531 where handler' (Exception.ErrorCall err) = handler err
1532
1533
1534 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1535 -- to use text files here, rather than binary files.
1536 writeFileAtomic :: FilePath -> String -> IO ()
1537 writeFileAtomic targetFile content = do
1538 (newFile, newHandle) <- openNewFile targetDir template
1539 do hPutStr newHandle content
1540 hClose newHandle
1541 #if mingw32_HOST_OS || mingw32_TARGET_OS
1542 renameFile newFile targetFile
1543 -- If the targetFile exists then renameFile will fail
1544 `catchIO` \err -> do
1545 exists <- doesFileExist targetFile
1546 if exists
1547 then do removeFile targetFile
1548 -- Big fat hairy race condition
1549 renameFile newFile targetFile
1550 -- If the removeFile succeeds and the renameFile fails
1551 -- then we've lost the atomic property.
1552 else throwIOIO err
1553 #else
1554 renameFile newFile targetFile
1555 #endif
1556 `Exception.onException` do hClose newHandle
1557 removeFile newFile
1558 where
1559 template = targetName <.> "tmp"
1560 targetDir | null targetDir_ = "."
1561 | otherwise = targetDir_
1562 --TODO: remove this when takeDirectory/splitFileName is fixed
1563 -- to always return a valid dir
1564 (targetDir_,targetName) = splitFileName targetFile
1565
1566 -- Ugh, this is a copy/paste of code from the base library, but
1567 -- if uses 666 rather than 600 for the permissions.
1568 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1569 openNewFile dir template = do
1570 pid <- c_getpid
1571 findTempName pid
1572 where
1573 -- We split off the last extension, so we can use .foo.ext files
1574 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1575 -- below filepath in the hierarchy here.
1576 (prefix,suffix) =
1577 case break (== '.') $ reverse template of
1578 -- First case: template contains no '.'s. Just re-reverse it.
1579 (rev_suffix, "") -> (reverse rev_suffix, "")
1580 -- Second case: template contains at least one '.'. Strip the
1581 -- dot from the prefix and prepend it to the suffix (if we don't
1582 -- do this, the unique number will get added after the '.' and
1583 -- thus be part of the extension, which is wrong.)
1584 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1585 -- Otherwise, something is wrong, because (break (== '.')) should
1586 -- always return a pair with either the empty string or a string
1587 -- beginning with '.' as the second component.
1588 _ -> error "bug in System.IO.openTempFile"
1589
1590 oflags = rw_flags .|. o_EXCL
1591
1592 #if __GLASGOW_HASKELL__ < 611
1593 withFilePath = withCString
1594 #endif
1595
1596 findTempName x = do
1597 fd <- withFilePath filepath $ \ f ->
1598 c_open f oflags 0o666
1599 if fd < 0
1600 then do
1601 errno <- getErrno
1602 if errno == eEXIST
1603 then findTempName (x+1)
1604 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1605 else do
1606 -- XXX We want to tell fdToHandle what the filepath is,
1607 -- as any exceptions etc will only be able to report the
1608 -- fd currently
1609 h <-
1610 #if __GLASGOW_HASKELL__ >= 609
1611 fdToHandle fd
1612 #else
1613 fdToHandle (fromIntegral fd)
1614 #endif
1615 `Exception.onException` c_close fd
1616 return (filepath, h)
1617 where
1618 filename = prefix ++ show x ++ suffix
1619 filepath = dir `combine` filename
1620
1621 -- XXX Copied from GHC.Handle
1622 std_flags, output_flags, rw_flags :: CInt
1623 std_flags = o_NONBLOCK .|. o_NOCTTY
1624 output_flags = std_flags .|. o_CREAT
1625 rw_flags = output_flags .|. o_RDWR
1626
1627 -- | The function splits the given string to substrings
1628 -- using 'isSearchPathSeparator'.
1629 parseSearchPath :: String -> [FilePath]
1630 parseSearchPath path = split path
1631 where
1632 split :: String -> [String]
1633 split s =
1634 case rest' of
1635 [] -> [chunk]
1636 _:rest -> chunk : split rest
1637 where
1638 chunk =
1639 case chunk' of
1640 #ifdef mingw32_HOST_OS
1641 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1642 #endif
1643 _ -> chunk'
1644
1645 (chunk', rest') = break isSearchPathSeparator s