1
{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
2
-----------------------------------------------------------------------------
4
-- (c) The University of Glasgow 2004-2009.
6
-- Package management tool
8
-----------------------------------------------------------------------------
10
module Main (main) where
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,
30
import System.Console.GetOpt
31
import qualified Control.Exception as Exception
34
import Data.Char ( isSpace, toLower )
36
import System.Directory ( doesDirectoryExist, getDirectoryContents,
37
doesFileExist, renameFile, removeFile )
38
import System.Exit ( exitWith, ExitCode(..) )
39
import System.Environment ( getArgs, getProgName, getEnv )
41
import System.IO.Error (try, isDoesNotExistError)
43
import Control.Concurrent
45
import qualified Data.ByteString.Lazy as B
46
import qualified Data.Binary as Bin
47
import qualified Data.Binary.Get as Bin
49
#if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS)
50
-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
55
#if __GLASGOW_HASKELL__ < 612
56
import System.Posix.Internals
57
import GHC.Handle (fdToHandle)
60
#ifdef mingw32_HOST_OS
61
import GHC.ConsoleHandler
63
import System.Posix hiding (fdToHandle)
66
import IO ( isPermissionError )
69
import System.Process(runInteractiveCommand)
70
import qualified System.Info(os)
73
#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
74
import System.Console.Terminfo as Terminfo
77
-- -----------------------------------------------------------------------------
84
case getOpt Permute (flags ++ deprecFlags) args of
85
(cli,_,[]) | FlagHelp `elem` cli -> do
86
prog <- getProgramName
87
bye (usageInfo (usageHeader prog) flags)
88
(cli,_,[]) | FlagVersion `elem` cli ->
91
case getVerbosity Normal cli of
92
Right v -> runit v cli nonopts
95
prog <- getProgramName
96
die (concat errors ++ usageInfo (usageHeader prog) flags)
98
-- -----------------------------------------------------------------------------
99
-- Command-line syntax
106
| FlagConfig FilePath
107
| FlagGlobalConfig FilePath
115
| FlagVerbosity (Maybe String)
118
flags :: [OptDescr Flag]
120
Option [] ["user"] (NoArg FlagUser)
121
"use the current user's package database",
122
Option [] ["global"] (NoArg FlagGlobal)
123
"use the global package database",
124
Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
125
"use the specified package config file",
126
Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
127
"location of the global package config",
128
Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
129
"never read the user package database",
130
Option [] ["force"] (NoArg FlagForce)
131
"ignore missing dependencies, directories, and libraries",
132
Option [] ["force-files"] (NoArg FlagForceFiles)
133
"ignore missing directories and libraries only",
134
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
135
"automatically build libs for GHCi (with register)",
136
Option ['?'] ["help"] (NoArg FlagHelp)
137
"display this help and exit",
138
Option ['V'] ["version"] (NoArg FlagVersion)
139
"output version information and exit",
140
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
141
"print output in easy-to-parse format for some commands",
142
Option [] ["names-only"] (NoArg FlagNamesOnly)
143
"only print package names, not versions; can only be used with list --simple-output",
144
Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
145
"ignore case for substring matching",
146
Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
147
"verbosity level (0-2, default 1)"
150
data Verbosity = Silent | Normal | Verbose
151
deriving (Show, Eq, Ord)
153
getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
154
getVerbosity v [] = Right v
155
getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
156
getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
157
getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
158
getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
159
getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
160
getVerbosity v (_ : fs) = getVerbosity v fs
162
deprecFlags :: [OptDescr Flag]
164
-- put deprecated flags here
167
ourCopyright :: String
168
ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
170
usageHeader :: String -> String
171
usageHeader prog = substProg prog $
173
" $p init {path}\n" ++
174
" Create and initialise a package database at the location {path}.\n" ++
175
" Packages can be registered in the new database using the register\n" ++
176
" command with --package-conf={path}. To use the new database with GHC,\n" ++
177
" use GHC's -package-conf flag.\n" ++
179
" $p register {filename | -}\n" ++
180
" Register the package using the specified installed package\n" ++
181
" description. The syntax for the latter is given in the $p\n" ++
182
" documentation. The input file should be encoded in UTF-8.\n" ++
184
" $p update {filename | -}\n" ++
185
" Register the package, overwriting any other package with the\n" ++
186
" same name. The input file should be encoded in UTF-8.\n" ++
188
" $p unregister {pkg-id}\n" ++
189
" Unregister the specified package.\n" ++
191
" $p expose {pkg-id}\n" ++
192
" Expose the specified package.\n" ++
194
" $p hide {pkg-id}\n" ++
195
" Hide the specified package.\n" ++
197
" $p list [pkg]\n" ++
198
" List registered packages in the global database, and also the\n" ++
199
" user database if --user is given. If a package name is given\n" ++
200
" all the registered versions will be listed in ascending order.\n" ++
201
" Accepts the --simple-output flag.\n" ++
204
" Generate a graph of the package dependencies in a form suitable\n" ++
205
" for input for the graphviz tools. For example, to generate a PDF" ++
206
" of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
208
" $p find-module {module}\n" ++
209
" List registered packages exposing module {module} in the global\n" ++
210
" database, and also the user database if --user is given.\n" ++
211
" All the registered versions will be listed in ascending order.\n" ++
212
" Accepts the --simple-output flag.\n" ++
214
" $p latest {pkg-id}\n" ++
215
" Prints the highest registered version of a package.\n" ++
218
" Check the consistency of package depenencies and list broken packages.\n" ++
219
" Accepts the --simple-output flag.\n" ++
221
" $p describe {pkg}\n" ++
222
" Give the registered description for the specified package. The\n" ++
223
" description is returned in precisely the syntax required by $p\n" ++
226
" $p field {pkg} {field}\n" ++
227
" Extract the specified field of the package description for the\n" ++
228
" specified package. Accepts comma-separated multiple fields.\n" ++
231
" Dump the registered description for every package. This is like\n" ++
232
" \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
233
" by tools that parse the results, rather than humans. The output is\n" ++
234
" always encoded in UTF-8, regardless of the current locale.\n" ++
237
" Regenerate the package database cache. This command should only be\n" ++
238
" necessary if you added a package to the database by dropping a file\n" ++
239
" into the database directory manually. By default, the global DB\n" ++
240
" is recached; to recache a different DB use --user or --package-conf\n" ++
241
" as appropriate.\n" ++
243
" Substring matching is supported for {module} in find-module and\n" ++
244
" for {pkg} in list, describe, and field, where a '*' indicates\n" ++
245
" open substring ends (prefix*, *suffix, *infix*).\n" ++
247
" When asked to modify a database (register, unregister, update,\n"++
248
" hide, expose, and also check), ghc-pkg modifies the global database by\n"++
249
" default. Specifying --user causes it to act on the user database,\n"++
250
" or --package-conf can be used to act on another database\n"++
251
" entirely. When multiple of these options are given, the rightmost\n"++
252
" one is used as the database to act upon.\n"++
254
" Commands that query the package database (list, tree, latest, describe,\n"++
255
" field) operate on the list of databases specified by the flags\n"++
256
" --user, --global, and --package-conf. If none of these flags are\n"++
257
" given, the default is --global --user.\n"++
259
" The following optional flags are also accepted:\n"
261
substProg :: String -> String -> String
263
substProg prog ('$':'p':xs) = prog ++ substProg prog xs
264
substProg prog (c:xs) = c : substProg prog xs
266
-- -----------------------------------------------------------------------------
269
data Force = NoForce | ForceFiles | ForceAll | CannotForce
272
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
274
runit :: Verbosity -> [Flag] -> [String] -> IO ()
275
runit verbosity cli nonopts = do
276
installSignalHandlers -- catch ^C and clean up
277
prog <- getProgramName
280
| FlagForce `elem` cli = ForceAll
281
| FlagForceFiles `elem` cli = ForceFiles
282
| otherwise = NoForce
283
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
284
splitFields fields = unfoldr splitComma (',':fields)
285
where splitComma "" = Nothing
286
splitComma fs = Just $ break (==',') (tail fs)
288
substringCheck :: String -> Maybe (String -> Bool)
289
substringCheck "" = Nothing
290
substringCheck "*" = Just (const True)
291
substringCheck [_] = Nothing
292
substringCheck (h:t) =
293
case (h, init t, last t) of
294
('*',s,'*') -> Just (isInfixOf (f s) . f)
295
('*',_, _ ) -> Just (isSuffixOf (f t) . f)
296
( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
298
where f | FlagIgnoreCase `elem` cli = map toLower
301
glob x | System.Info.os=="mingw32" = do
302
-- glob echoes its argument, after win32 filename globbing
303
(_,o,_,_) <- runInteractiveCommand ("glob "++x)
304
txt <- hGetContents o
306
glob x | otherwise = return [x]
309
-- first, parse the command
312
-- dummy command to demonstrate usage and permit testing
313
-- without messing things up; use glob to selectively enable
314
-- windows filename globbing for file parameters
315
-- register, update, FlagGlobalConfig, FlagConfig; others?
316
["glob", filename] -> do
318
glob filename >>= print
320
["init", filename] ->
321
initPackageDB filename verbosity cli
322
["register", filename] ->
323
registerPackage filename verbosity cli auto_ghci_libs False force
324
["update", filename] ->
325
registerPackage filename verbosity cli auto_ghci_libs True force
326
["unregister", pkgid_str] -> do
327
pkgid <- readGlobPkgId pkgid_str
328
unregisterPackage pkgid verbosity cli force
329
["expose", pkgid_str] -> do
330
pkgid <- readGlobPkgId pkgid_str
331
exposePackage pkgid verbosity cli force
332
["hide", pkgid_str] -> do
333
pkgid <- readGlobPkgId pkgid_str
334
hidePackage pkgid verbosity cli force
336
listPackages verbosity cli Nothing Nothing
337
["list", pkgid_str] ->
338
case substringCheck pkgid_str of
339
Nothing -> do pkgid <- readGlobPkgId pkgid_str
340
listPackages verbosity cli (Just (Id pkgid)) Nothing
341
Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
343
showPackageDot verbosity cli
344
["find-module", moduleName] -> do
345
let match = maybe (==moduleName) id (substringCheck moduleName)
346
listPackages verbosity cli Nothing (Just match)
347
["latest", pkgid_str] -> do
348
pkgid <- readGlobPkgId pkgid_str
349
latestPackage verbosity cli pkgid
350
["describe", pkgid_str] ->
351
case substringCheck pkgid_str of
352
Nothing -> do pkgid <- readGlobPkgId pkgid_str
353
describePackage verbosity cli (Id pkgid)
354
Just m -> describePackage verbosity cli (Substring pkgid_str m)
355
["field", pkgid_str, fields] ->
356
case substringCheck pkgid_str of
357
Nothing -> do pkgid <- readGlobPkgId pkgid_str
358
describeField verbosity cli (Id pkgid)
360
Just m -> describeField verbosity cli (Substring pkgid_str m)
363
checkConsistency verbosity cli
366
dumpPackages verbosity cli
369
recache verbosity cli
372
die ("missing command\n" ++
373
usageInfo (usageHeader prog) flags)
375
die ("command-line syntax error\n" ++
376
usageInfo (usageHeader prog) flags)
378
parseCheck :: ReadP a a -> String -> String -> IO a
379
parseCheck parser str what =
380
case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
382
_ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
384
readGlobPkgId :: String -> IO PackageIdentifier
385
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
387
parseGlobPackageId :: ReadP r PackageIdentifier
393
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
395
-- globVersion means "all versions"
396
globVersion :: Version
397
globVersion = Version{ versionBranch=[], versionTags=["*"] }
399
-- -----------------------------------------------------------------------------
402
-- Some commands operate on a single database:
403
-- register, unregister, expose, hide
404
-- however these commands also check the union of the available databases
405
-- in order to check consistency. For example, register will check that
406
-- dependencies exist before registering a package.
408
-- Some commands operate on multiple databases, with overlapping semantics:
409
-- list, describe, field
412
= PackageDB { location :: FilePath,
413
packages :: [InstalledPackageInfo] }
415
type PackageDBStack = [PackageDB]
416
-- A stack of package databases. Convention: head is the topmost
419
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
420
allPackagesInStack = concatMap packages
422
getPkgDatabases :: Verbosity
423
-> Bool -- we are modifying, not reading
424
-> Bool -- read caches, if available
426
-> IO (PackageDBStack,
427
-- the real package DB stack: [global,user] ++
428
-- DBs specified on the command line with -f.
430
-- which one to modify, if any
432
-- the package DBs specified on the command
433
-- line, or [global,user] otherwise. This
434
-- is used as the list of package DBs for
435
-- commands that just read the DB, such as 'list'.
437
getPkgDatabases verbosity modify use_cache my_flags = do
438
-- first we determine the location of the global package config. On Windows,
439
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
440
-- location is passed to the binary using the --global-config flag by the
442
let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
444
case [ f | FlagGlobalConfig f <- my_flags ] of
445
[] -> do mb_dir <- getLibDir
447
Nothing -> die err_msg
449
r <- lookForPackageDBIn dir
451
Nothing -> die ("Can't find package database in " ++ dir)
452
Just path -> return path
453
fs -> return (last fs)
455
let no_user_db = FlagNoUserDb `elem` my_flags
457
-- get the location of the user package database, and create it if necessary
458
-- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
459
e_appdir <- try $ getAppUserDataDirectory "ghc"
462
if no_user_db then return Nothing else
464
Left _ -> return Nothing
466
let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
467
dir = appdir </> subdir
468
r <- lookForPackageDBIn dir
470
Nothing -> return (Just (dir </> "package.conf.d", False))
471
Just f -> return (Just (f, True))
473
-- If the user database doesn't exist, and this command isn't a
474
-- "modify" command, then we won't attempt to create or use it.
476
| Just (user_conf,user_exists) <- mb_user_conf,
477
modify || user_exists = [user_conf, global_conf]
478
| otherwise = [global_conf]
480
e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
483
Left _ -> sys_databases
485
| last cs == "" -> init cs ++ sys_databases
487
where cs = parseSearchPath path
489
-- The "global" database is always the one at the bottom of the stack.
490
-- This is the database we modify by default.
491
virt_global_conf = last env_stack
493
let db_flags = [ f | Just f <- map is_db_flag my_flags ]
494
where is_db_flag FlagUser
495
| Just (user_conf, _user_exists) <- mb_user_conf
497
is_db_flag FlagGlobal = Just virt_global_conf
498
is_db_flag (FlagConfig f) = Just f
499
is_db_flag _ = Nothing
501
let flag_db_names | null db_flags = env_stack
502
| otherwise = reverse (nub db_flags)
504
-- For a "modify" command, treat all the databases as
505
-- a stack, where we are modifying the top one, but it
506
-- can refer to packages in databases further down the
509
-- -f flags on the command line add to the database
510
-- stack, unless any of them are present in the stack
512
let final_stack = filter (`notElem` env_stack)
513
[ f | FlagConfig f <- reverse my_flags ]
516
-- the database we actually modify is the one mentioned
517
-- rightmost on the command-line.
519
| not modify = Nothing
520
| null db_flags = Just virt_global_conf
521
| otherwise = Just (last db_flags)
523
db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
525
let flag_db_stack = [ db | db_name <- flag_db_names,
526
db <- db_stack, location db == db_name ]
528
return (db_stack, to_modify, flag_db_stack)
531
lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
532
lookForPackageDBIn dir = do
533
let path_dir = dir </> "package.conf.d"
534
exists_dir <- doesDirectoryExist path_dir
535
if exists_dir then return (Just path_dir) else do
536
let path_file = dir </> "package.conf"
537
exists_file <- doesFileExist path_file
538
if exists_file then return (Just path_file) else return Nothing
540
readParseDatabase :: Verbosity
541
-> Maybe (FilePath,Bool)
546
readParseDatabase verbosity mb_user_conf use_cache path
547
-- the user database (only) is allowed to be non-existent
548
| Just (user_conf,False) <- mb_user_conf, path == user_conf
549
= return PackageDB { location = path, packages = [] }
551
= do e <- try $ getDirectoryContents path
554
pkgs <- parseMultiPackageConf verbosity path
555
return PackageDB{ location = path, packages = pkgs }
557
| not use_cache -> ignore_cache
559
let cache = path </> cachefilename
560
tdir <- getModificationTime path
561
e_tcache <- try $ getModificationTime cache
564
when (verbosity > Normal) $
565
warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
568
| tcache >= tdir -> do
569
when (verbosity > Normal) $
570
putStrLn ("using cache: " ++ cache)
571
pkgs <- myReadBinPackageDB cache
572
let pkgs' = map convertPackageInfoIn pkgs
573
return PackageDB { location = path, packages = pkgs' }
575
when (verbosity >= Normal) $ do
576
warn ("WARNING: cache is out of date: " ++ cache)
577
warn " use 'ghc-pkg recache' to fix."
581
let confs = filter (".conf" `isSuffixOf`) fs
582
pkgs <- mapM (parseSingletonPackageConf verbosity) $
584
return PackageDB { location = path, packages = pkgs }
586
-- read the package.cache file strictly, to work around a problem with
587
-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
588
-- after it has been completely read, leading to a sharing violation
590
myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
591
myReadBinPackageDB filepath = do
592
h <- openBinaryFile filepath ReadMode
594
b <- B.hGet h (fromIntegral sz)
596
return $ Bin.runGet Bin.get b
598
parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
599
parseMultiPackageConf verbosity file = do
600
when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
601
str <- readUTF8File file
602
let pkgs = map convertPackageInfoIn $ read str
603
Exception.evaluate pkgs
605
die ("error while parsing " ++ file ++ ": " ++ show e)
607
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
608
parseSingletonPackageConf verbosity file = do
609
when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
610
readUTF8File file >>= parsePackageInfo
612
cachefilename :: FilePath
613
cachefilename = "package.cache"
615
-- -----------------------------------------------------------------------------
616
-- Creating a new package DB
618
initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
619
initPackageDB filename verbosity _flags = do
620
let eexist = die ("cannot create: " ++ filename ++ " already exists")
621
b1 <- doesFileExist filename
623
b2 <- doesDirectoryExist filename
625
changeDB verbosity [] PackageDB{ location = filename, packages = [] }
627
-- -----------------------------------------------------------------------------
630
registerPackage :: FilePath
633
-> Bool -- auto_ghci_libs
637
registerPackage input verbosity my_flags auto_ghci_libs update force = do
638
(db_stack, Just to_modify, _flag_dbs) <-
639
getPkgDatabases verbosity True True my_flags
642
db_to_operate_on = my_head "register" $
643
filter ((== to_modify).location) db_stack
648
when (verbosity >= Normal) $
649
putStr "Reading package info from stdin ... "
650
#if __GLASGOW_HASKELL__ >= 612
651
-- fix the encoding to UTF-8, since this is an interchange format
652
hSetEncoding stdin utf8
656
when (verbosity >= Normal) $
657
putStr ("Reading package info from " ++ show f ++ " ... ")
660
expanded <- expandEnvVars s force
662
pkg <- parsePackageInfo expanded
663
when (verbosity >= Normal) $
666
let truncated_stack = dropWhile ((/= to_modify).location) db_stack
667
-- truncate the stack for validation, because we don't allow
668
-- packages lower in the stack to refer to those higher up.
669
validatePackageConfig pkg truncated_stack auto_ghci_libs update force
671
removes = [ RemovePackage p
672
| p <- packages db_to_operate_on,
673
sourcePackageId p == sourcePackageId pkg ]
675
changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
679
-> IO InstalledPackageInfo
680
parsePackageInfo str =
681
case parseInstalledPackageInfo str of
682
ParseOk _warns ok -> return ok
683
ParseFailed err -> case locatedErrorMsg err of
684
(Nothing, s) -> die s
685
(Just l, s) -> die (show l ++ ": " ++ s)
687
-- -----------------------------------------------------------------------------
688
-- Making changes to a package database
690
data DBOp = RemovePackage InstalledPackageInfo
691
| AddPackage InstalledPackageInfo
692
| ModifyPackage InstalledPackageInfo
694
changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
695
changeDB verbosity cmds db = do
696
let db' = updateInternalDB db cmds
697
isfile <- doesFileExist (location db)
699
then writeNewConfig verbosity (location db') (packages db')
701
createDirectoryIfMissing True (location db)
702
changeDBDir verbosity cmds db'
704
updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
705
updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
707
do_cmd pkgs (RemovePackage p) =
708
filter ((/= installedPackageId p) . installedPackageId) pkgs
709
do_cmd pkgs (AddPackage p) = p : pkgs
710
do_cmd pkgs (ModifyPackage p) =
711
do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
714
changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
715
changeDBDir verbosity cmds db = do
717
updateDBCache verbosity db
719
do_cmd (RemovePackage p) = do
720
let file = location db </> display (installedPackageId p) <.> "conf"
721
when (verbosity > Normal) $ putStrLn ("removing " ++ file)
723
do_cmd (AddPackage p) = do
724
let file = location db </> display (installedPackageId p) <.> "conf"
725
when (verbosity > Normal) $ putStrLn ("writing " ++ file)
726
writeFileUtf8Atomic file (showInstalledPackageInfo p)
727
do_cmd (ModifyPackage p) =
728
do_cmd (AddPackage p)
730
updateDBCache :: Verbosity -> PackageDB -> IO ()
731
updateDBCache verbosity db = do
732
let filename = location db </> cachefilename
733
when (verbosity > Normal) $
734
putStrLn ("writing cache " ++ filename)
735
writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
737
if isPermissionError e
738
then die (filename ++ ": you don't have permission to modify this file")
741
-- -----------------------------------------------------------------------------
742
-- Exposing, Hiding, Unregistering are all similar
744
exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
745
exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
747
hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
748
hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
750
unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
751
unregisterPackage = modifyPackage RemovePackage
754
:: (InstalledPackageInfo -> DBOp)
760
modifyPackage fn pkgid verbosity my_flags force = do
761
(db_stack, Just _to_modify, _flag_dbs) <-
762
getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
764
(db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
766
db_name = location db
769
pids = map sourcePackageId ps
771
cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
772
new_db = updateInternalDB db cmds
774
old_broken = brokenPackages (allPackagesInStack db_stack)
775
rest_of_stack = filter ((/= db_name) . location) db_stack
776
new_stack = new_db : rest_of_stack
777
new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
778
newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
780
when (not (null newly_broken)) $
781
dieOrForceAll force ("unregistering " ++ display pkgid ++
782
" would break the following packages: "
783
++ unwords (map display newly_broken))
785
changeDB verbosity cmds db
787
recache :: Verbosity -> [Flag] -> IO ()
788
recache verbosity my_flags = do
789
(db_stack, Just to_modify, _flag_dbs) <-
790
getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
792
db_to_operate_on = my_head "recache" $
793
filter ((== to_modify).location) db_stack
795
changeDB verbosity [] db_to_operate_on
797
-- -----------------------------------------------------------------------------
800
listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
801
-> Maybe (String->Bool)
803
listPackages verbosity my_flags mPackageName mModuleName = do
804
let simple_output = FlagSimpleOutput `elem` my_flags
805
(db_stack, _, flag_db_stack) <-
806
getPkgDatabases verbosity False True{-use cache-} my_flags
808
let db_stack_filtered -- if a package is given, filter out all other packages
809
| Just this <- mPackageName =
810
[ db{ packages = filter (this `matchesPkg`) (packages db) }
811
| db <- flag_db_stack ]
812
| Just match <- mModuleName = -- packages which expose mModuleName
813
[ db{ packages = filter (match `exposedInPkg`) (packages db) }
814
| db <- flag_db_stack ]
815
| otherwise = flag_db_stack
818
= [ db{ packages = sort_pkgs (packages db) }
819
| db <- db_stack_filtered ]
820
where sort_pkgs = sortBy cmpPkgIds
821
cmpPkgIds pkg1 pkg2 =
822
case pkgName p1 `compare` pkgName p2 of
825
EQ -> pkgVersion p1 `compare` pkgVersion p2
826
where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
828
stack = reverse db_stack_sorted
830
match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
832
pkg_map = allPackagesInStack db_stack
833
broken = map sourcePackageId (brokenPackages pkg_map)
835
show_normal PackageDB{ location = db_name, packages = pkg_confs } =
836
hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
838
pp_pkgs = map pp_pkg pkg_confs
840
| sourcePackageId p `elem` broken = printf "{%s}" doc
842
| otherwise = printf "(%s)" doc
843
where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
846
InstalledPackageId ipid = installedPackageId p
847
pkg = display (sourcePackageId p)
849
show_simple = simplePackageList my_flags . allPackagesInStack
851
when (not (null broken) && not simple_output && verbosity /= Silent) $ do
852
prog <- getProgramName
853
warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
855
if simple_output then show_simple stack else do
857
#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
858
mapM_ show_normal stack
861
show_colour withF db =
862
mconcat $ map (<#> termText "\n") $
863
(termText (location db) :
864
map (termText " " <#>) (map pp_pkg (packages db)))
867
| sourcePackageId p `elem` broken = withF Red doc
869
| otherwise = withF Blue doc
870
where doc | verbosity >= Verbose
871
= termText (printf "%s (%s)" pkg ipid)
875
InstalledPackageId ipid = installedPackageId p
876
pkg = display (sourcePackageId p)
878
is_tty <- hIsTerminalDevice stdout
880
then mapM_ show_normal stack
881
else do tty <- Terminfo.setupTermFromEnv
882
case Terminfo.getCapability tty withForegroundColor of
883
Nothing -> mapM_ show_normal stack
884
Just w -> runTermOutput tty $ mconcat $
885
map (show_colour w) stack
888
simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
889
simplePackageList my_flags pkgs = do
890
let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
892
strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
893
when (not (null pkgs)) $
894
hPutStrLn stdout $ concat $ intersperse " " strs
896
showPackageDot :: Verbosity -> [Flag] -> IO ()
897
showPackageDot verbosity myflags = do
898
(_, _, flag_db_stack) <-
899
getPkgDatabases verbosity False True{-use cache-} myflags
901
let all_pkgs = allPackagesInStack flag_db_stack
902
ipix = PackageIndex.fromList all_pkgs
905
let quote s = '"':s ++ "\""
906
mapM_ putStrLn [ quote from ++ " -> " ++ quote to
908
let from = display (sourcePackageId p),
910
Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
911
let to = display (sourcePackageId dep)
915
-- -----------------------------------------------------------------------------
916
-- Prints the highest (hidden or exposed) version of a package
918
latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
919
latestPackage verbosity my_flags pkgid = do
920
(_, _, flag_db_stack) <-
921
getPkgDatabases verbosity False True{-use cache-} my_flags
923
ps <- findPackages flag_db_stack (Id pkgid)
924
show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
926
show_pkg [] = die "no matches"
927
show_pkg pids = hPutStrLn stdout (display (last pids))
929
-- -----------------------------------------------------------------------------
932
describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
933
describePackage verbosity my_flags pkgarg = do
934
(_, _, flag_db_stack) <-
935
getPkgDatabases verbosity False True{-use cache-} my_flags
936
ps <- findPackages flag_db_stack pkgarg
939
dumpPackages :: Verbosity -> [Flag] -> IO ()
940
dumpPackages verbosity my_flags = do
941
(_, _, flag_db_stack) <-
942
getPkgDatabases verbosity False True{-use cache-} my_flags
943
doDump (allPackagesInStack flag_db_stack)
945
doDump :: [InstalledPackageInfo] -> IO ()
947
#if __GLASGOW_HASKELL__ >= 612
948
-- fix the encoding to UTF-8, since this is an interchange format
949
hSetEncoding stdout utf8
951
mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
953
-- PackageId is can have globVersion for the version
954
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
955
findPackages db_stack pkgarg
956
= fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
958
findPackagesByDB :: PackageDBStack -> PackageArg
959
-> IO [(PackageDB, [InstalledPackageInfo])]
960
findPackagesByDB db_stack pkgarg
961
= case [ (db, matched)
963
let matched = filter (pkgarg `matchesPkg`) (packages db),
964
not (null matched) ] of
965
[] -> die ("cannot find package " ++ pkg_msg pkgarg)
968
pkg_msg (Id pkgid) = display pkgid
969
pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
971
matches :: PackageIdentifier -> PackageIdentifier -> Bool
973
= (pkgName pid == pkgName pid')
974
&& (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
976
realVersion :: PackageIdentifier -> Bool
977
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
978
-- when versionBranch == [], this is a glob
980
matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
981
(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
982
(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
984
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
985
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
987
-- -----------------------------------------------------------------------------
990
describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
991
describeField verbosity my_flags pkgarg fields = do
992
(_, _, flag_db_stack) <-
993
getPkgDatabases verbosity False True{-use cache-} my_flags
994
fns <- toFields fields
995
ps <- findPackages flag_db_stack pkgarg
996
let top_dir = takeDirectory (location (last flag_db_stack))
997
mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
998
where toFields [] = return []
999
toFields (f:fs) = case toField f of
1000
Nothing -> die ("unknown field: " ++ f)
1001
Just fn -> do fns <- toFields fs
1003
selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1005
mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1006
-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1007
-- with the current topdir (obtained from the -B option).
1008
mungePackagePaths top_dir ps = map munge_pkg ps
1010
munge_pkg p = p{ importDirs = munge_paths (importDirs p),
1011
includeDirs = munge_paths (includeDirs p),
1012
libraryDirs = munge_paths (libraryDirs p),
1013
frameworkDirs = munge_paths (frameworkDirs p),
1014
haddockInterfaces = munge_paths (haddockInterfaces p),
1015
haddockHTMLs = munge_paths (haddockHTMLs p)
1018
munge_paths = map munge_path
1021
| Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
1022
| Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1025
toHttpPath p = "file:///" ++ p
1027
maybePrefixMatch :: String -> String -> Maybe String
1028
maybePrefixMatch [] rest = Just rest
1029
maybePrefixMatch (_:_) [] = Nothing
1030
maybePrefixMatch (p:pat) (r:rest)
1031
| p == r = maybePrefixMatch pat rest
1032
| otherwise = Nothing
1034
toField :: String -> Maybe (InstalledPackageInfo -> String)
1035
-- backwards compatibility:
1036
toField "import_dirs" = Just $ strList . importDirs
1037
toField "source_dirs" = Just $ strList . importDirs
1038
toField "library_dirs" = Just $ strList . libraryDirs
1039
toField "hs_libraries" = Just $ strList . hsLibraries
1040
toField "extra_libraries" = Just $ strList . extraLibraries
1041
toField "include_dirs" = Just $ strList . includeDirs
1042
toField "c_includes" = Just $ strList . includes
1043
toField "package_deps" = Just $ strList . map display. depends
1044
toField "extra_cc_opts" = Just $ strList . ccOptions
1045
toField "extra_ld_opts" = Just $ strList . ldOptions
1046
toField "framework_dirs" = Just $ strList . frameworkDirs
1047
toField "extra_frameworks"= Just $ strList . frameworks
1048
toField s = showInstalledPackageInfoField s
1050
strList :: [String] -> String
1054
-- -----------------------------------------------------------------------------
1055
-- Check: Check consistency of installed packages
1057
checkConsistency :: Verbosity -> [Flag] -> IO ()
1058
checkConsistency verbosity my_flags = do
1059
(db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1060
-- check behaves like modify for the purposes of deciding which
1061
-- databases to use, because ordering is important.
1063
let simple_output = FlagSimpleOutput `elem` my_flags
1065
let pkgs = allPackagesInStack db_stack
1068
(_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1070
then do when (not simple_output) $ do
1071
_ <- reportValidateErrors [] ws "" Nothing
1075
when (not simple_output) $ do
1076
reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1077
_ <- reportValidateErrors es ws " " Nothing
1081
broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1083
let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1084
where not_in p = sourcePackageId p `notElem` all_ps
1085
all_ps = map sourcePackageId pkgs1
1087
let not_broken_pkgs = filterOut broken_pkgs pkgs
1088
(_, trans_broken_pkgs) = closure [] not_broken_pkgs
1089
all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1091
when (not (null all_broken_pkgs)) $ do
1093
then simplePackageList my_flags all_broken_pkgs
1095
reportError ("\nThe following packages are broken, either because they have a problem\n"++
1096
"listed above, or because they depend on a broken package.")
1097
mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1099
when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1102
closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1103
-> ([InstalledPackageInfo], [InstalledPackageInfo])
1104
closure pkgs db_stack = go pkgs db_stack
1106
go avail not_avail =
1107
case partition (depsAvailable avail) not_avail of
1108
([], not_avail') -> (avail, not_avail')
1109
(new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1111
depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1113
depsAvailable pkgs_ok pkg = null dangling
1114
where dangling = filter (`notElem` pids) (depends pkg)
1115
pids = map installedPackageId pkgs_ok
1117
-- we want mutually recursive groups of package to show up
1118
-- as broken. (#1750)
1120
brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1121
brokenPackages pkgs = snd (closure [] pkgs)
1123
-- -----------------------------------------------------------------------------
1124
-- Manipulating package.conf files
1126
type InstalledPackageInfoString = InstalledPackageInfo_ String
1128
convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1129
convertPackageInfoOut
1130
(pkgconf@(InstalledPackageInfo { exposedModules = e,
1131
hiddenModules = h })) =
1132
pkgconf{ exposedModules = map display e,
1133
hiddenModules = map display h }
1135
convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1136
convertPackageInfoIn
1137
(pkgconf@(InstalledPackageInfo { exposedModules = e,
1138
hiddenModules = h })) =
1139
pkgconf{ exposedModules = map convert e,
1140
hiddenModules = map convert h }
1141
where convert = fromJust . simpleParse
1143
writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1144
writeNewConfig verbosity filename ipis = do
1145
when (verbosity >= Normal) $
1146
hPutStr stdout "Writing new package config file... "
1147
createDirectoryIfMissing True $ takeDirectory filename
1148
let shown = concat $ intersperse ",\n "
1149
$ map (show . convertPackageInfoOut) ipis
1150
fileContents = "[" ++ shown ++ "\n]"
1151
writeFileUtf8Atomic filename fileContents
1153
if isPermissionError e
1154
then die (filename ++ ": you don't have permission to modify this file")
1156
when (verbosity >= Normal) $
1157
hPutStrLn stdout "done."
1159
-----------------------------------------------------------------------------
1160
-- Sanity-check a new package config, and automatically build GHCi libs
1163
type ValidateError = (Force,String)
1164
type ValidateWarning = String
1166
newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1168
instance Monad Validate where
1169
return a = V $ return (a, [], [])
1171
(a, es, ws) <- runValidate m
1172
(b, es', ws') <- runValidate (k a)
1173
return (b,es++es',ws++ws')
1175
verror :: Force -> String -> Validate ()
1176
verror f s = V (return ((),[(f,s)],[]))
1178
vwarn :: String -> Validate ()
1179
vwarn s = V (return ((),[],["Warning: " ++ s]))
1181
liftIO :: IO a -> Validate a
1182
liftIO k = V (k >>= \a -> return (a,[],[]))
1184
-- returns False if we should die
1185
reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1186
-> String -> Maybe Force -> IO Bool
1187
reportValidateErrors es ws prefix mb_force = do
1188
mapM_ (warn . (prefix++)) ws
1189
oks <- mapM report es
1193
| Just force <- mb_force
1195
then do reportError (prefix ++ s ++ " (ignoring)")
1197
else if f < CannotForce
1198
then do reportError (prefix ++ s ++ " (use --force to override)")
1200
else do reportError err
1202
| otherwise = do reportError err
1207
validatePackageConfig :: InstalledPackageInfo
1209
-> Bool -- auto-ghc-libs
1210
-> Bool -- update, or check
1213
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1214
(_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1215
ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1216
when (not ok) $ exitWith (ExitFailure 1)
1218
checkPackageConfig :: InstalledPackageInfo
1220
-> Bool -- auto-ghc-libs
1221
-> Bool -- update, or check
1223
checkPackageConfig pkg db_stack auto_ghci_libs update = do
1224
checkInstalledPackageId pkg db_stack update
1226
checkDuplicates db_stack pkg update
1227
mapM_ (checkDep db_stack) (depends pkg)
1228
checkDuplicateDepends (depends pkg)
1229
mapM_ (checkDir False "import-dirs") (importDirs pkg)
1230
mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1231
mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1233
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1234
-- ToDo: check these somehow?
1235
-- extra_libraries :: [String],
1236
-- c_includes :: [String],
1238
checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1240
checkInstalledPackageId ipi db_stack update = do
1241
let ipid@(InstalledPackageId str) = installedPackageId ipi
1242
when (null str) $ verror CannotForce "missing id field"
1243
let dups = [ p | p <- allPackagesInStack db_stack,
1244
installedPackageId p == ipid ]
1245
when (not update && not (null dups)) $
1246
verror CannotForce $
1247
"package(s) with this id already exist: " ++
1248
unwords (map (display.packageId) dups)
1250
-- When the package name and version are put together, sometimes we can
1251
-- end up with a package id that cannot be parsed. This will lead to
1252
-- difficulties when the user wants to refer to the package later, so
1253
-- we check that the package id can be parsed properly here.
1254
checkPackageId :: InstalledPackageInfo -> Validate ()
1255
checkPackageId ipi =
1256
let str = display (sourcePackageId ipi) in
1257
case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1259
[] -> verror CannotForce ("invalid package identifier: " ++ str)
1260
_ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1262
checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1263
checkDuplicates db_stack pkg update = do
1265
pkgid = sourcePackageId pkg
1266
pkgs = packages (head db_stack)
1268
-- Check whether this package id already exists in this DB
1270
when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1271
verror CannotForce $
1272
"package " ++ display pkgid ++ " is already installed"
1275
uncasep = map toLower . display
1276
dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1278
when (not update && not (null dups)) $ verror ForceAll $
1279
"Package names may be treated case-insensitively in the future.\n"++
1280
"Package " ++ display pkgid ++
1281
" overlaps with: " ++ unwords (map display dups)
1284
checkDir :: Bool -> String -> String -> Validate ()
1285
checkDir warn_only thisfield d
1286
| "$topdir" `isPrefixOf` d = return ()
1287
| "$httptopdir" `isPrefixOf` d = return ()
1288
-- can't check these, because we don't know what $(http)topdir is
1289
| isRelative d = verror ForceFiles $
1290
thisfield ++ ": " ++ d ++ " is a relative path"
1291
-- relative paths don't make any sense; #4134
1293
there <- liftIO $ doesDirectoryExist d
1295
let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
1299
else verror ForceFiles msg
1301
checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1302
checkDep db_stack pkgid
1303
| pkgid `elem` pkgids = return ()
1304
| otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1305
++ "\" doesn't exist")
1307
all_pkgs = allPackagesInStack db_stack
1308
pkgids = map installedPackageId all_pkgs
1310
checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1311
checkDuplicateDepends deps
1312
| null dups = return ()
1313
| otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1314
unwords (map display dups))
1316
dups = [ p | (p:_:_) <- group (sort deps) ]
1318
checkHSLib :: [String] -> Bool -> String -> Validate ()
1319
checkHSLib dirs auto_ghci_libs lib = do
1320
let batch_lib_file = "lib" ++ lib ++ ".a"
1321
m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1323
Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1325
Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1327
doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1328
doesFileExistOnPath file path = go path
1329
where go [] = return Nothing
1330
go (p:ps) = do b <- doesFileExistIn file p
1331
if b then return (Just p) else go ps
1333
doesFileExistIn :: String -> String -> IO Bool
1334
doesFileExistIn lib d
1335
| "$topdir" `isPrefixOf` d = return True
1336
| "$httptopdir" `isPrefixOf` d = return True
1337
| otherwise = doesFileExist (d </> lib)
1339
checkModules :: InstalledPackageInfo -> Validate ()
1340
checkModules pkg = do
1341
mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1343
findModule modl = do
1344
-- there's no .hi file for GHC.Prim
1345
if modl == fromString "GHC.Prim" then return () else do
1346
let file = toFilePath modl <.> "hi"
1347
m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1348
when (isNothing m) $
1349
verror ForceFiles ("file " ++ file ++ " is missing")
1351
checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1352
checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1353
| auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1355
m <- doesFileExistOnPath ghci_lib_file dirs
1356
when (isNothing m && ghci_lib_file /= "HSrts.o") $
1357
warn ("warning: can't find GHCi lib " ++ ghci_lib_file)
1359
ghci_lib_file = lib <.> "o"
1361
-- automatically build the GHCi version of a batch lib,
1362
-- using ld --whole-archive.
1364
autoBuildGHCiLib :: String -> String -> String -> IO ()
1365
autoBuildGHCiLib dir batch_file ghci_file = do
1366
let ghci_lib_file = dir ++ '/':ghci_file
1367
batch_lib_file = dir ++ '/':batch_file
1368
hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1369
#if defined(darwin_HOST_OS)
1370
r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1371
#elif defined(mingw32_HOST_OS)
1372
execDir <- getLibDir
1373
r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1375
r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1377
when (r /= ExitSuccess) $ exitWith r
1378
hPutStrLn stderr (" done.")
1380
-- -----------------------------------------------------------------------------
1381
-- Searching for modules
1385
findModules :: [FilePath] -> IO [String]
1387
mms <- mapM searchDir paths
1390
searchDir path prefix = do
1391
fs <- getDirectoryEntries path `catch` \_ -> return []
1392
searchEntries path prefix fs
1394
searchEntries path prefix [] = return []
1395
searchEntries path prefix (f:fs)
1396
| looks_like_a_module = do
1397
ms <- searchEntries path prefix fs
1398
return (prefix `joinModule` f : ms)
1399
| looks_like_a_component = do
1400
ms <- searchDir (path </> f) (prefix `joinModule` f)
1401
ms' <- searchEntries path prefix fs
1404
searchEntries path prefix fs
1407
(base,suffix) = splitFileExt f
1408
looks_like_a_module =
1409
suffix `elem` haskell_suffixes &&
1410
all okInModuleName base
1411
looks_like_a_component =
1412
null suffix && all okInModuleName base
1418
-- ---------------------------------------------------------------------------
1419
-- expanding environment variables in the package configuration
1421
expandEnvVars :: String -> Force -> IO String
1422
expandEnvVars str0 force = go str0 ""
1424
go "" acc = return $! reverse acc
1425
go ('$':'{':str) acc | (var, '}':rest) <- break close str
1426
= do value <- lookupEnvVar var
1427
go rest (reverse value ++ acc)
1428
where close c = c == '}' || c == '\n' -- don't span newlines
1432
lookupEnvVar :: String -> IO String
1434
catch (System.Environment.getEnv nm)
1435
(\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1439
-----------------------------------------------------------------------------
1441
getProgramName :: IO String
1442
getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1443
where str `withoutSuffix` suff
1444
| suff `isSuffixOf` str = take (length str - length suff) str
1447
bye :: String -> IO a
1448
bye s = putStr s >> exitWith ExitSuccess
1450
die :: String -> IO a
1453
dieWith :: Int -> String -> IO a
1456
prog <- getProgramName
1457
hPutStrLn stderr (prog ++ ": " ++ s)
1458
exitWith (ExitFailure ec)
1460
dieOrForceAll :: Force -> String -> IO ()
1461
dieOrForceAll ForceAll s = ignoreError s
1462
dieOrForceAll _other s = dieForcible s
1464
warn :: String -> IO ()
1467
ignoreError :: String -> IO ()
1468
ignoreError s = reportError (s ++ " (ignoring)")
1470
reportError :: String -> IO ()
1471
reportError s = do hFlush stdout; hPutStrLn stderr s
1473
dieForcible :: String -> IO ()
1474
dieForcible s = die (s ++ " (use --force to override)")
1476
my_head :: String -> [a] -> a
1477
my_head s [] = error s
1478
my_head _ (x : _) = x
1480
-----------------------------------------
1481
-- Cut and pasted from ghc/compiler/main/SysTools
1483
#if defined(mingw32_HOST_OS)
1484
subst :: Char -> Char -> String -> String
1485
subst a b ls = map (\ x -> if x == a then b else x) ls
1487
unDosifyPath :: FilePath -> FilePath
1488
unDosifyPath xs = subst '\\' '/' xs
1490
getLibDir :: IO (Maybe String)
1491
getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1493
-- (getExecDir cmd) returns the directory in which the current
1494
-- executable, which should be called 'cmd', is running
1495
-- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1496
-- you'll get "/a/b/c" back as the result
1497
getExecDir :: String -> IO (Maybe String)
1499
getExecPath >>= maybe (return Nothing) removeCmdSuffix
1500
where initN n = reverse . drop n . reverse
1501
removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1503
getExecPath :: IO (Maybe String)
1505
allocaArray len $ \buf -> do
1506
ret <- getModuleFileName nullPtr buf len
1507
if ret == 0 then return Nothing
1508
else liftM Just $ peekCString buf
1509
where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1511
foreign import stdcall unsafe "GetModuleFileNameA"
1512
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1515
getLibDir :: IO (Maybe String)
1516
getLibDir = return Nothing
1519
-----------------------------------------
1520
-- Adapted from ghc/compiler/utils/Panic
1522
installSignalHandlers :: IO ()
1523
installSignalHandlers = do
1524
threadid <- myThreadId
1526
interrupt = Exception.throwTo threadid
1527
(Exception.ErrorCall "interrupted")
1529
#if !defined(mingw32_HOST_OS)
1530
_ <- installHandler sigQUIT (Catch interrupt) Nothing
1531
_ <- installHandler sigINT (Catch interrupt) Nothing
1534
-- GHC 6.3+ has support for console events on Windows
1535
-- NOTE: running GHCi under a bash shell for some reason requires
1536
-- you to press Ctrl-Break rather than Ctrl-C to provoke
1537
-- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1538
-- why --SDM 17/12/2004
1539
let sig_handler ControlC = interrupt
1540
sig_handler Break = interrupt
1541
sig_handler _ = return ()
1543
_ <- installHandler (Catch sig_handler)
1547
#if mingw32_HOST_OS || mingw32_TARGET_OS
1548
throwIOIO :: Exception.IOException -> IO a
1549
throwIOIO = Exception.throwIO
1551
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1552
catchIO = Exception.catch
1555
catchError :: IO a -> (String -> IO a) -> IO a
1556
catchError io handler = io `Exception.catch` handler'
1557
where handler' (Exception.ErrorCall err) = handler err
1560
writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1561
writeBinaryFileAtomic targetFile obj =
1562
withFileAtomic targetFile $ \h -> do
1563
hSetBinaryMode h True
1564
B.hPutStr h (Bin.encode obj)
1566
writeFileUtf8Atomic :: FilePath -> String -> IO ()
1567
writeFileUtf8Atomic targetFile content =
1568
withFileAtomic targetFile $ \h -> do
1569
#if __GLASGOW_HASKELL__ >= 612
1574
-- copied from Cabal's Distribution.Simple.Utils, except that we want
1575
-- to use text files here, rather than binary files.
1576
withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1577
withFileAtomic targetFile write_content = do
1578
(newFile, newHandle) <- openNewFile targetDir template
1579
do write_content newHandle
1581
#if mingw32_HOST_OS || mingw32_TARGET_OS
1582
renameFile newFile targetFile
1583
-- If the targetFile exists then renameFile will fail
1584
`catchIO` \err -> do
1585
exists <- doesFileExist targetFile
1587
then do removeFileSafe targetFile
1588
-- Big fat hairy race condition
1589
renameFile newFile targetFile
1590
-- If the removeFile succeeds and the renameFile fails
1591
-- then we've lost the atomic property.
1594
renameFile newFile targetFile
1596
`Exception.onException` do hClose newHandle
1597
removeFileSafe newFile
1599
template = targetName <.> "tmp"
1600
targetDir | null targetDir_ = "."
1601
| otherwise = targetDir_
1602
--TODO: remove this when takeDirectory/splitFileName is fixed
1603
-- to always return a valid dir
1604
(targetDir_,targetName) = splitFileName targetFile
1606
openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1607
openNewFile dir template = do
1608
#if __GLASGOW_HASKELL__ >= 612
1609
-- this was added to System.IO in 6.12.1
1610
-- we must use this version because the version below opens the file
1612
openTempFileWithDefaultPermissions dir template
1614
-- Ugh, this is a copy/paste of code from the base library, but
1615
-- if uses 666 rather than 600 for the permissions.
1619
-- We split off the last extension, so we can use .foo.ext files
1620
-- for temporary files (hidden on Unix OSes). Unfortunately we're
1621
-- below filepath in the hierarchy here.
1623
case break (== '.') $ reverse template of
1624
-- First case: template contains no '.'s. Just re-reverse it.
1625
(rev_suffix, "") -> (reverse rev_suffix, "")
1626
-- Second case: template contains at least one '.'. Strip the
1627
-- dot from the prefix and prepend it to the suffix (if we don't
1628
-- do this, the unique number will get added after the '.' and
1629
-- thus be part of the extension, which is wrong.)
1630
(rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1631
-- Otherwise, something is wrong, because (break (== '.')) should
1632
-- always return a pair with either the empty string or a string
1633
-- beginning with '.' as the second component.
1634
_ -> error "bug in System.IO.openTempFile"
1636
oflags = rw_flags .|. o_EXCL
1638
withFilePath = withCString
1641
fd <- withFilePath filepath $ \ f ->
1642
c_open f oflags 0o666
1647
then findTempName (x+1)
1648
else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1650
-- XXX We want to tell fdToHandle what the filepath is,
1651
-- as any exceptions etc will only be able to report the
1655
`Exception.onException` c_close fd
1656
return (filepath, h)
1658
filename = prefix ++ show x ++ suffix
1659
filepath = dir `combine` filename
1661
-- XXX Copied from GHC.Handle
1662
std_flags, output_flags, rw_flags :: CInt
1663
std_flags = o_NONBLOCK .|. o_NOCTTY
1664
output_flags = std_flags .|. o_CREAT
1665
rw_flags = output_flags .|. o_RDWR
1666
#endif /* GLASGOW_HASKELL < 612 */
1668
-- | The function splits the given string to substrings
1669
-- using 'isSearchPathSeparator'.
1670
parseSearchPath :: String -> [FilePath]
1671
parseSearchPath path = split path
1673
split :: String -> [String]
1677
_:rest -> chunk : split rest
1681
#ifdef mingw32_HOST_OS
1682
('\"':xs@(_:_)) | last xs == '\"' -> init xs
1686
(chunk', rest') = break isSearchPathSeparator s
1688
readUTF8File :: FilePath -> IO String
1689
readUTF8File file = do
1690
h <- openFile file ReadMode
1691
#if __GLASGOW_HASKELL__ >= 612
1692
-- fix the encoding to UTF-8
1697
-- removeFileSave doesn't throw an exceptions, if the file is already deleted
1698
removeFileSafe :: FilePath -> IO ()
1700
removeFile fn `catch` \ e ->
1701
when (not $ isDoesNotExistError e) $ ioError e
added
removed
utils/ghc-pkg/Main.hs
