1 {-# OPTIONS -fglasgow-exts #-}
2 -----------------------------------------------------------------------------
4 -- (c) The University of Glasgow 2004.
6 -- Package management tool
8 -----------------------------------------------------------------------------
12 -- * expanding of variables in new-style package conf
13 -- * version manipulation (checking whether old version exists,
14 -- hiding old version?)
16 module Main (main) where
18 import Version ( version, targetOS, targetARCH )
19 import Distribution.InstalledPackageInfo
20 import Distribution.Compat.ReadP
21 import Distribution.ParseUtils
22 import Distribution.Package
23 import Distribution.Version
24 import System.FilePath
27 import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
28 import Compat.RawSystem ( rawSystem )
30 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
31 import System.Cmd ( rawSystem )
36 #include "../../includes/ghcconfig.h"
38 import System.Console.GetOpt
39 import Text.PrettyPrint
40 import qualified Control.Exception as Exception
43 import Data.Char ( isSpace, toLower )
45 import System.Directory ( doesDirectoryExist, getDirectoryContents,
46 doesFileExist, renameFile, removeFile )
47 import System.Exit ( exitWith, ExitCode(..) )
48 import System.Environment ( getArgs, getProgName, getEnv )
50 import System.IO.Error (try)
51 import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub )
52 import Control.Concurrent
54 #ifdef mingw32_HOST_OS
56 import Foreign.C.String
57 import GHC.ConsoleHandler
62 import IO ( isPermissionError, isDoesNotExistError )
64 -- -----------------------------------------------------------------------------
71 case getOpt Permute (flags ++ deprecFlags) args of
72 (cli,_,[]) | FlagHelp `elem` cli -> do
73 prog <- getProgramName
74 bye (usageInfo (usageHeader prog) flags)
75 (cli,_,[]) | FlagVersion `elem` cli ->
80 prog <- getProgramName
81 die (concat errors ++ usageInfo (usageHeader prog) flags)
83 -- -----------------------------------------------------------------------------
84 -- Command-line syntax
92 | FlagGlobalConfig FilePath
100 flags :: [OptDescr Flag]
102 Option [] ["user"] (NoArg FlagUser)
103 "use the current user's package database",
104 Option [] ["global"] (NoArg FlagGlobal)
105 "use the global package database",
106 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
107 "use the specified package config file",
108 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
109 "location of the global package config",
110 Option [] ["force"] (NoArg FlagForce)
111 "ignore missing dependencies, directories, and libraries",
112 Option [] ["force-files"] (NoArg FlagForceFiles)
113 "ignore missing directories and libraries only",
114 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
115 "automatically build libs for GHCi (with register)",
116 Option ['?'] ["help"] (NoArg FlagHelp)
117 "display this help and exit",
118 Option ['V'] ["version"] (NoArg FlagVersion)
119 "output version information and exit",
120 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
121 "print output in easy-to-parse format for some commands",
122 Option [] ["names-only"] (NoArg FlagNamesOnly)
123 "only print package names, not versions; can only be used with list --simple-output"
126 deprecFlags :: [OptDescr Flag]
128 -- put deprecated flags here
131 ourCopyright :: String
132 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
134 usageHeader :: String -> String
135 usageHeader prog = substProg prog $
137 " $p register {filename | -}\n" ++
138 " Register the package using the specified installed package\n" ++
139 " description. The syntax for the latter is given in the $p\n" ++
140 " documentation.\n" ++
142 " $p update {filename | -}\n" ++
143 " Register the package, overwriting any other package with the\n" ++
146 " $p unregister {pkg-id}\n" ++
147 " Unregister the specified package.\n" ++
149 " $p expose {pkg-id}\n" ++
150 " Expose the specified package.\n" ++
152 " $p hide {pkg-id}\n" ++
153 " Hide the specified package.\n" ++
155 " $p list [pkg]\n" ++
156 " List registered packages in the global database, and also the\n" ++
157 " user database if --user is given. If a package name is given\n" ++
158 " all the registered versions will be listed in ascending order.\n" ++
159 " Accepts the --simple-output flag.\n" ++
161 " $p latest pkg\n" ++
162 " Prints the highest registered version of a package.\n" ++
165 " Check the consistency of package depenencies and list broken packages.\n" ++
166 " Accepts the --simple-output flag.\n" ++
168 " $p describe {pkg-id}\n" ++
169 " Give the registered description for the specified package. The\n" ++
170 " description is returned in precisely the syntax required by $p\n" ++
173 " $p field {pkg-id} {field}\n" ++
174 " Extract the specified field of the package description for the\n" ++
175 " specified package.\n" ++
177 " When asked to modify a database (register, unregister, update,\n"++
178 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
179 " default. Specifying --user causes it to act on the user database,\n"++
180 " or --package-conf can be used to act on another database\n"++
181 " entirely. When multiple of these options are given, the rightmost\n"++
182 " one is used as the database to act upon.\n"++
184 " Commands that query the package database (list, latest, describe,\n"++
185 " field) operate on the list of databases specified by the flags\n"++
186 " --user, --global, and --package-conf. If none of these flags are\n"++
187 " given, the default is --global --user.\n"++
189 " The following optional flags are also accepted:\n"
191 substProg :: String -> String -> String
193 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
194 substProg prog (c:xs) = c : substProg prog xs
196 -- -----------------------------------------------------------------------------
199 data Force = ForceAll | ForceFiles | NoForce
201 runit :: [Flag] -> [String] -> IO ()
202 runit cli nonopts = do
203 installSignalHandlers -- catch ^C and clean up
204 prog <- getProgramName
207 | FlagForce `elem` cli = ForceAll
208 | FlagForceFiles `elem` cli = ForceFiles
209 | otherwise = NoForce
210 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
212 -- first, parse the command
214 ["register", filename] ->
215 registerPackage filename cli auto_ghci_libs False force
216 ["update", filename] ->
217 registerPackage filename cli auto_ghci_libs True force
218 ["unregister", pkgid_str] -> do
219 pkgid <- readGlobPkgId pkgid_str
220 unregisterPackage pkgid cli
221 ["expose", pkgid_str] -> do
222 pkgid <- readGlobPkgId pkgid_str
223 exposePackage pkgid cli
224 ["hide", pkgid_str] -> do
225 pkgid <- readGlobPkgId pkgid_str
226 hidePackage pkgid cli
228 listPackages cli Nothing Nothing
229 ["list", pkgid_str] -> do
230 pkgid <- readGlobPkgId pkgid_str
231 listPackages cli (Just pkgid) Nothing
232 ["find-module", moduleName] -> do
233 listPackages cli Nothing (Just moduleName)
234 ["latest", pkgid_str] -> do
235 pkgid <- readGlobPkgId pkgid_str
236 latestPackage cli pkgid
237 ["describe", pkgid_str] -> do
238 pkgid <- readGlobPkgId pkgid_str
239 describePackage cli pkgid
240 ["field", pkgid_str, field] -> do
241 pkgid <- readGlobPkgId pkgid_str
242 describeField cli pkgid field
246 die ("missing command\n" ++
247 usageInfo (usageHeader prog) flags)
249 die ("command-line syntax error\n" ++
250 usageInfo (usageHeader prog) flags)
252 parseCheck :: ReadP a a -> String -> String -> IO a
253 parseCheck parser str what =
254 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
256 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
258 readGlobPkgId :: String -> IO PackageIdentifier
259 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
261 parseGlobPackageId :: ReadP r PackageIdentifier
265 (do n <- parsePackageName; string "-*"
266 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
268 -- globVersion means "all versions"
269 globVersion :: Version
270 globVersion = Version{ versionBranch=[], versionTags=["*"] }
272 -- -----------------------------------------------------------------------------
275 -- Some commands operate on a single database:
276 -- register, unregister, expose, hide
277 -- however these commands also check the union of the available databases
278 -- in order to check consistency. For example, register will check that
279 -- dependencies exist before registering a package.
281 -- Some commands operate on multiple databases, with overlapping semantics:
282 -- list, describe, field
284 type PackageDBName = FilePath
285 type PackageDB = [InstalledPackageInfo]
287 type PackageDBStack = [(PackageDBName,PackageDB)]
288 -- A stack of package databases. Convention: head is the topmost
289 -- in the stack. Earlier entries override later one.
291 getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
292 getPkgDatabases modify flags = do
293 -- first we determine the location of the global package config. On Windows,
294 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
295 -- location is passed to the binary using the --global-config flag by the
297 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
299 case [ f | FlagGlobalConfig f <- flags ] of
300 [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
302 Nothing -> die err_msg
303 Just dir -> return (dir </> "package.conf")
304 fs -> return (last fs)
306 let global_conf_dir = global_conf ++ ".d"
307 global_conf_dir_exists <- doesDirectoryExist global_conf_dir
309 if global_conf_dir_exists
310 then do files <- getDirectoryContents global_conf_dir
311 return [ global_conf_dir ++ '/' : file
313 , isSuffixOf ".conf" file]
316 -- get the location of the user package database, and create it if necessary
317 appdir <- getAppUserDataDirectory "ghc"
320 subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
321 archdir = appdir </> subdir
322 user_conf = archdir </> "package.conf"
323 user_exists <- doesFileExist user_conf
325 -- If the user database doesn't exist, and this command isn't a
326 -- "modify" command, then we won't attempt to create or use it.
328 | modify || user_exists = user_conf : global_confs ++ [global_conf]
329 | otherwise = global_confs ++ [global_conf]
331 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
334 Left _ -> sys_databases
336 | last cs == "" -> init cs ++ sys_databases
338 where cs = splitSearchPath path
340 -- The "global" database is always the one at the bottom of the stack.
341 -- This is the database we modify by default.
342 virt_global_conf = last env_stack
344 let db_flags = [ f | Just f <- map is_db_flag flags ]
345 where is_db_flag FlagUser = Just user_conf
346 is_db_flag FlagGlobal = Just virt_global_conf
347 is_db_flag (FlagConfig f) = Just f
348 is_db_flag _ = Nothing
352 then -- For a "read" command, we use all the databases
353 -- specified on the command line. If there are no
354 -- command-line flags specifying databases, the default
355 -- is to use all the ones we know about.
356 if null db_flags then return env_stack
357 else return (reverse (nub db_flags))
359 -- For a "modify" command, treat all the databases as
360 -- a stack, where we are modifying the top one, but it
361 -- can refer to packages in databases further down the
364 -- -f flags on the command line add to the database
365 -- stack, unless any of them are present in the stack
367 flag_stack = filter (`notElem` env_stack)
368 [ f | FlagConfig f <- reverse flags ]
372 | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
373 | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
376 then modifying virt_global_conf
377 else modifying (head db_flags)
379 db_stack <- mapM readParseDatabase final_stack
382 readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
383 readParseDatabase filename = do
384 str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
385 let packages = read str
386 Exception.evaluate packages
387 `Exception.catch` \e->
388 die ("error while parsing " ++ filename ++ ": " ++ show e)
389 return (filename,packages)
391 emptyPackageConfig :: String
392 emptyPackageConfig = "[]"
394 -- -----------------------------------------------------------------------------
397 registerPackage :: FilePath
399 -> Bool -- auto_ghci_libs
403 registerPackage input flags auto_ghci_libs update force = do
404 db_stack <- getPkgDatabases True flags
406 db_to_operate_on = my_head "db" db_stack
407 db_filename = fst db_to_operate_on
413 putStr "Reading package info from stdin ... "
416 putStr ("Reading package info from " ++ show f ++ " ... ")
419 expanded <- expandEnvVars s force
421 pkg <- parsePackageInfo expanded
424 validatePackageConfig pkg db_stack auto_ghci_libs update force
425 let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
426 not_this p = package p /= package pkg
427 savingOldConfig db_filename $
428 writeNewConfig db_filename new_details
432 -> IO InstalledPackageInfo
433 parsePackageInfo str =
434 case parseInstalledPackageInfo str of
435 ParseOk _warns ok -> return ok
436 ParseFailed err -> case locatedErrorMsg err of
437 (Nothing, s) -> die s
438 (Just l, s) -> die (show l ++ ": " ++ s)
440 -- -----------------------------------------------------------------------------
441 -- Exposing, Hiding, Unregistering are all similar
443 exposePackage :: PackageIdentifier -> [Flag] -> IO ()
444 exposePackage = modifyPackage (\p -> [p{exposed=True}])
446 hidePackage :: PackageIdentifier -> [Flag] -> IO ()
447 hidePackage = modifyPackage (\p -> [p{exposed=False}])
449 unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
450 unregisterPackage = modifyPackage (\p -> [])
453 :: (InstalledPackageInfo -> [InstalledPackageInfo])
457 modifyPackage fn pkgid flags = do
458 db_stack <- getPkgDatabases True{-modify-} flags
459 let ((db_name, pkgs) : _) = db_stack
460 ps <- findPackages [(db_name,pkgs)] pkgid
461 let pids = map package ps
462 let new_config = concat (map modify pkgs)
464 | package pkg `elem` pids = fn pkg
466 savingOldConfig db_name $
467 writeNewConfig db_name new_config
469 -- -----------------------------------------------------------------------------
472 listPackages :: [Flag] -> Maybe PackageIdentifier -> Maybe String -> IO ()
473 listPackages flags mPackageName mModuleName = do
474 let simple_output = FlagSimpleOutput `elem` flags
475 db_stack <- getPkgDatabases False flags
476 let db_stack_filtered -- if a package is given, filter out all other packages
477 | Just this <- mPackageName =
478 map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
480 | Just this <- mModuleName = -- packages which expose mModuleName
481 map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs))
483 | otherwise = db_stack
486 = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
487 where sort_pkgs = sortBy cmpPkgIds
488 cmpPkgIds pkg1 pkg2 =
489 case pkgName p1 `compare` pkgName p2 of
492 EQ -> pkgVersion p1 `compare` pkgVersion p2
493 where (p1,p2) = (package pkg1, package pkg2)
495 pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
496 show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
498 show_func (reverse db_stack_sorted)
500 where show_normal pkg_map (db_name,pkg_confs) =
501 hPutStrLn stdout (render $
502 text db_name <> colon $$ nest 4 packages
504 where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
506 | isBrokenPackage p pkg_map = braces doc
508 | otherwise = parens doc
509 where doc = text (showPackageId (package p))
511 show_simple db_stack = do
512 let showPkg = if FlagNamesOnly `elem` flags then pkgName
514 pkgs = map showPkg $ sortBy compPkgIdVer $
515 map package (concatMap snd db_stack)
516 when (not (null pkgs)) $
517 hPutStrLn stdout $ concat $ intersperse " " pkgs
519 -- -----------------------------------------------------------------------------
520 -- Prints the highest (hidden or exposed) version of a package
522 latestPackage :: [Flag] -> PackageIdentifier -> IO ()
523 latestPackage flags pkgid = do
524 db_stack <- getPkgDatabases False flags
525 ps <- findPackages db_stack pkgid
526 show_pkg (sortBy compPkgIdVer (map package ps))
528 show_pkg [] = die "no matches"
529 show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
531 -- -----------------------------------------------------------------------------
534 describePackage :: [Flag] -> PackageIdentifier -> IO ()
535 describePackage flags pkgid = do
536 db_stack <- getPkgDatabases False flags
537 ps <- findPackages db_stack pkgid
538 mapM_ (putStrLn . showInstalledPackageInfo) ps
540 -- PackageId is can have globVersion for the version
541 findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
542 findPackages db_stack pkgid
543 = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
544 [] -> die ("cannot find package " ++ showPackageId pkgid)
547 all_pkgs = concat (map snd db_stack)
549 matches :: PackageIdentifier -> PackageIdentifier -> Bool
551 = (pkgName pid == pkgName pid')
552 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
554 matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
555 pid `matchesPkg` pkg = pid `matches` package pkg
557 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
558 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
560 exposedInPkg :: String -> InstalledPackageInfo -> Bool
561 moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg
563 -- -----------------------------------------------------------------------------
566 describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
567 describeField flags pkgid field = do
568 db_stack <- getPkgDatabases False flags
569 case toField field of
570 Nothing -> die ("unknown field: " ++ field)
572 ps <- findPackages db_stack pkgid
573 let top_dir = takeDirectory (fst (last db_stack))
574 mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
576 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
577 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
578 -- with the current topdir (obtained from the -B option).
579 mungePackagePaths top_dir ps = map munge_pkg ps
581 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
582 includeDirs = munge_paths (includeDirs p),
583 libraryDirs = munge_paths (libraryDirs p),
584 frameworkDirs = munge_paths (frameworkDirs p),
585 haddockInterfaces = munge_paths (haddockInterfaces p),
586 haddockHTMLs = munge_paths (haddockHTMLs p)
589 munge_paths = map munge_path
592 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
593 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
596 toHttpPath p = "file:///" ++ p
598 maybePrefixMatch :: String -> String -> Maybe String
599 maybePrefixMatch [] rest = Just rest
600 maybePrefixMatch (_:_) [] = Nothing
601 maybePrefixMatch (p:pat) (r:rest)
602 | p == r = maybePrefixMatch pat rest
603 | otherwise = Nothing
605 toField :: String -> Maybe (InstalledPackageInfo -> String)
606 -- backwards compatibility:
607 toField "import_dirs" = Just $ strList . importDirs
608 toField "source_dirs" = Just $ strList . importDirs
609 toField "library_dirs" = Just $ strList . libraryDirs
610 toField "hs_libraries" = Just $ strList . hsLibraries
611 toField "extra_libraries" = Just $ strList . extraLibraries
612 toField "include_dirs" = Just $ strList . includeDirs
613 toField "c_includes" = Just $ strList . includes
614 toField "package_deps" = Just $ strList . map showPackageId. depends
615 toField "extra_cc_opts" = Just $ strList . ccOptions
616 toField "extra_ld_opts" = Just $ strList . ldOptions
617 toField "framework_dirs" = Just $ strList . frameworkDirs
618 toField "extra_frameworks"= Just $ strList . frameworks
619 toField s = showInstalledPackageInfoField s
621 strList :: [String] -> String
625 -- -----------------------------------------------------------------------------
626 -- Check: Check consistency of installed packages
628 checkConsistency :: [Flag] -> IO ()
629 checkConsistency flags = do
630 db_stack <- getPkgDatabases True flags
631 -- check behaves like modify for the purposes of deciding which
632 -- databases to use, because ordering is important.
633 let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
636 let broken_deps = missingPackageDeps p pkgs
637 guard (not . null $ broken_deps)
638 return (pid, broken_deps)
639 mapM_ (putStrLn . render . show_func) broken_pkgs
641 show_func | FlagSimpleOutput `elem` flags = show_simple
642 | otherwise = show_normal
643 show_simple (pid,deps) =
644 text (showPackageId pid) <> colon
645 <+> fsep (punctuate comma (map (text . showPackageId) deps))
646 show_normal (pid,deps) =
647 text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
648 $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
650 missingPackageDeps :: InstalledPackageInfo
651 -> [(PackageIdentifier, InstalledPackageInfo)]
652 -> [PackageIdentifier]
653 missingPackageDeps pkg pkg_map =
654 [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
655 [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
657 isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
658 isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
661 -- -----------------------------------------------------------------------------
662 -- Manipulating package.conf files
664 writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
665 writeNewConfig filename packages = do
666 hPutStr stdout "Writing new package config file... "
667 createDirectoryIfMissing True $ takeDirectory filename
668 h <- openFile filename WriteMode `catch` \e ->
669 if isPermissionError e
670 then die (filename ++ ": you don't have permission to modify this file")
672 let shown = concat $ intersperse ",\n " $ map show packages
673 fileContents = "[" ++ shown ++ "\n]"
674 hPutStrLn h fileContents
676 hPutStrLn stdout "done."
678 savingOldConfig :: FilePath -> IO () -> IO ()
679 savingOldConfig filename io = Exception.block $ do
680 hPutStr stdout "Saving old package config file... "
681 -- mv rather than cp because we've already done an hGetContents
682 -- on this file so we won't be able to open it for writing
683 -- unless we move the old one out of the way...
684 let oldFile = filename ++ ".old"
685 restore_on_error <- catch (renameFile filename oldFile >> return True) $
687 unless (isDoesNotExistError err) $ do
688 hPutStrLn stderr (unwords ["Unable to rename", show filename,
692 (do hPutStrLn stdout "done."; io)
693 `Exception.catch` \e -> do
694 hPutStr stdout ("WARNING: an error was encountered while writing "
695 ++ "the new configuration.\n")
696 -- remove any partially complete new version:
697 try (removeFile filename)
698 -- and attempt to restore the old one, if we had one:
699 when restore_on_error $ do
700 hPutStr stdout "Attempting to restore the old configuration... "
701 do renameFile oldFile filename
702 hPutStrLn stdout "done."
703 `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
704 -- Note the above renameFile sometimes fails on Windows with
705 -- "permission denied", I have no idea why --SDM.
708 -----------------------------------------------------------------------------
709 -- Sanity-check a new package config, and automatically build GHCi libs
712 validatePackageConfig :: InstalledPackageInfo
714 -> Bool -- auto-ghc-libs
718 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
720 checkDuplicates db_stack pkg update force
721 mapM_ (checkDep db_stack force) (depends pkg)
722 mapM_ (checkDir force) (importDirs pkg)
723 mapM_ (checkDir force) (libraryDirs pkg)
724 mapM_ (checkDir force) (includeDirs pkg)
725 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
726 -- ToDo: check these somehow?
727 -- extra_libraries :: [String],
728 -- c_includes :: [String],
730 -- When the package name and version are put together, sometimes we can
731 -- end up with a package id that cannot be parsed. This will lead to
732 -- difficulties when the user wants to refer to the package later, so
733 -- we check that the package id can be parsed properly here.
734 checkPackageId :: InstalledPackageInfo -> IO ()
736 let str = showPackageId (package ipi) in
737 case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
739 [] -> die ("invalid package identifier: " ++ str)
740 _ -> die ("ambiguous package identifier: " ++ str)
742 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO ()
743 checkDuplicates db_stack pkg update force = do
746 (_top_db_name, pkgs) : _ = db_stack
748 -- Check whether this package id already exists in this DB
750 when (not update && (pkgid `elem` map package pkgs)) $
751 die ("package " ++ showPackageId pkgid ++ " is already installed")
754 uncasep = map toLower . showPackageId
755 dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
757 when (not update && not (null dups)) $ dieOrForceAll force $
758 "Package names may be treated case-insensitively in the future.\n"++
759 "Package " ++ showPackageId pkgid ++
760 " overlaps with: " ++ unwords (map showPackageId dups)
763 checkDir :: Force -> String -> IO ()
765 | "$topdir" `isPrefixOf` d = return ()
766 | "$httptopdir" `isPrefixOf` d = return ()
767 -- can't check these, because we don't know what $(http)topdir is
769 there <- doesDirectoryExist d
771 (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
773 checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
774 checkDep db_stack force pkgid
775 | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
776 | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
779 -- for backwards compat, we treat 0.0 as a special version,
780 -- and don't check that it actually exists.
781 real_version = realVersion pkgid
783 name_exists = any (\p -> pkgName (package p) == name) all_pkgs
786 all_pkgs = concat (map snd db_stack)
787 pkgids = map package all_pkgs
789 realVersion :: PackageIdentifier -> Bool
790 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
792 checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
793 checkHSLib dirs auto_ghci_libs force lib = do
794 let batch_lib_file = "lib" ++ lib ++ ".a"
795 bs <- mapM (doesLibExistIn batch_lib_file) dirs
796 case [ dir | (exists,dir) <- zip bs dirs, exists ] of
797 [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
799 (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
801 doesLibExistIn :: String -> String -> IO Bool
803 | "$topdir" `isPrefixOf` d = return True
804 | "$httptopdir" `isPrefixOf` d = return True
805 | otherwise = doesFileExist (d ++ '/':lib)
807 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
808 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
809 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
811 bs <- mapM (doesLibExistIn ghci_lib_file) dirs
812 case [dir | (exists,dir) <- zip bs dirs, exists] of
813 [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
816 ghci_lib_file = lib ++ ".o"
818 -- automatically build the GHCi version of a batch lib,
819 -- using ld --whole-archive.
821 autoBuildGHCiLib :: String -> String -> String -> IO ()
822 autoBuildGHCiLib dir batch_file ghci_file = do
823 let ghci_lib_file = dir ++ '/':ghci_file
824 batch_lib_file = dir ++ '/':batch_file
825 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
826 #if defined(darwin_HOST_OS)
827 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
828 #elif defined(mingw32_HOST_OS)
829 execDir <- getExecDir "/bin/ghc-pkg.exe"
830 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
832 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
834 when (r /= ExitSuccess) $ exitWith r
835 hPutStrLn stderr (" done.")
837 -- -----------------------------------------------------------------------------
838 -- Searching for modules
842 findModules :: [FilePath] -> IO [String]
844 mms <- mapM searchDir paths
847 searchDir path prefix = do
848 fs <- getDirectoryEntries path `catch` \_ -> return []
849 searchEntries path prefix fs
851 searchEntries path prefix [] = return []
852 searchEntries path prefix (f:fs)
853 | looks_like_a_module = do
854 ms <- searchEntries path prefix fs
855 return (prefix `joinModule` f : ms)
856 | looks_like_a_component = do
857 ms <- searchDir (path </> f) (prefix `joinModule` f)
858 ms' <- searchEntries path prefix fs
861 searchEntries path prefix fs
864 (base,suffix) = splitFileExt f
865 looks_like_a_module =
866 suffix `elem` haskell_suffixes &&
867 all okInModuleName base
868 looks_like_a_component =
869 null suffix && all okInModuleName base
875 -- ---------------------------------------------------------------------------
876 -- expanding environment variables in the package configuration
878 expandEnvVars :: String -> Force -> IO String
879 expandEnvVars str force = go str ""
881 go "" acc = return $! reverse acc
882 go ('$':'{':str) acc | (var, '}':rest) <- break close str
883 = do value <- lookupEnvVar var
884 go rest (reverse value ++ acc)
885 where close c = c == '}' || c == '\n' -- don't span newlines
889 lookupEnvVar :: String -> IO String
891 catch (System.Environment.getEnv nm)
892 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
896 -----------------------------------------------------------------------------
898 getProgramName :: IO String
899 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
900 where str `withoutSuffix` suff
901 | suff `isSuffixOf` str = take (length str - length suff) str
904 bye :: String -> IO a
905 bye s = putStr s >> exitWith ExitSuccess
907 die :: String -> IO a
910 prog <- getProgramName
911 hPutStrLn stderr (prog ++ ": " ++ s)
912 exitWith (ExitFailure 1)
914 dieOrForceAll :: Force -> String -> IO ()
915 dieOrForceAll ForceAll s = ignoreError s
916 dieOrForceAll _other s = dieForcible s
918 dieOrForceFile :: Force -> String -> IO ()
919 dieOrForceFile ForceAll s = ignoreError s
920 dieOrForceFile ForceFiles s = ignoreError s
921 dieOrForceFile _other s = dieForcible s
923 ignoreError :: String -> IO ()
924 ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
926 dieForcible :: String -> IO ()
927 dieForcible s = die (s ++ " (use --force to override)")
929 my_head :: String -> [a] -> a
930 my_head s [] = error s
933 -----------------------------------------
934 -- Cut and pasted from ghc/compiler/main/SysTools
936 #if defined(mingw32_HOST_OS)
937 subst :: Char -> Char -> String -> String
938 subst a b ls = map (\ x -> if x == a then b else x) ls
940 unDosifyPath :: FilePath -> FilePath
941 unDosifyPath xs = subst '\\' '/' xs
943 getExecDir :: String -> IO (Maybe String)
944 -- (getExecDir cmd) returns the directory in which the current
945 -- executable, which should be called 'cmd', is running
946 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
947 -- you'll get "/a/b/c" back as the result
949 = allocaArray len $ \buf -> do
950 ret <- getModuleFileName nullPtr buf len
951 if ret == 0 then return Nothing
952 else do s <- peekCString buf
953 return (Just (reverse (drop (length cmd)
954 (reverse (unDosifyPath s)))))
956 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
958 foreign import stdcall unsafe "GetModuleFileNameA"
959 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
961 getExecDir :: String -> IO (Maybe String)
962 getExecDir _ = return Nothing
965 -----------------------------------------
966 -- Adapted from ghc/compiler/utils/Panic
968 installSignalHandlers :: IO ()
969 installSignalHandlers = do
970 threadid <- myThreadId
972 interrupt = throwTo threadid (Exception.ErrorCall "interrupted")
974 #if !defined(mingw32_HOST_OS)
975 installHandler sigQUIT (Catch interrupt) Nothing
976 installHandler sigINT (Catch interrupt) Nothing
978 #elif __GLASGOW_HASKELL__ >= 603
979 -- GHC 6.3+ has support for console events on Windows
980 -- NOTE: running GHCi under a bash shell for some reason requires
981 -- you to press Ctrl-Break rather than Ctrl-C to provoke
982 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
983 -- why --SDM 17/12/2004
984 let sig_handler ControlC = interrupt
985 sig_handler Break = interrupt
986 sig_handler _ = return ()
988 installHandler (Catch sig_handler)