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 )
46 import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) )
48 import System.IO.Error (try)
49 import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub )
51 #ifdef mingw32_HOST_OS
53 import Foreign.C.String
56 import IO ( isPermissionError, isDoesNotExistError )
58 -- -----------------------------------------------------------------------------
65 case getOpt Permute (flags ++ deprecFlags) args of
66 (cli,_,[]) | FlagHelp `elem` cli -> do
67 prog <- getProgramName
68 bye (usageInfo (usageHeader prog) flags)
69 (cli,_,[]) | FlagVersion `elem` cli ->
74 prog <- getProgramName
75 die (concat errors ++ usageInfo (usageHeader prog) flags)
77 -- -----------------------------------------------------------------------------
78 -- Command-line syntax
86 | FlagGlobalConfig FilePath
94 flags :: [OptDescr Flag]
96 Option [] ["user"] (NoArg FlagUser)
97 "use the current user's package database",
98 Option [] ["global"] (NoArg FlagGlobal)
99 "use the global package database",
100 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
101 "use the specified package config file",
102 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
103 "location of the global package config",
104 Option [] ["force"] (NoArg FlagForce)
105 "ignore missing dependencies, directories, and libraries",
106 Option [] ["force-files"] (NoArg FlagForceFiles)
107 "ignore missing directories and libraries only",
108 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
109 "automatically build libs for GHCi (with register)",
110 Option ['?'] ["help"] (NoArg FlagHelp)
111 "display this help and exit",
112 Option ['V'] ["version"] (NoArg FlagVersion)
113 "output version information and exit",
114 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
115 "print output in easy-to-parse format for some commands",
116 Option [] ["names-only"] (NoArg FlagNamesOnly)
117 "only print package names, not versions; can only be used with list --simple-output"
120 deprecFlags :: [OptDescr Flag]
122 -- put deprecated flags here
125 ourCopyright :: String
126 ourCopyright = "GHC package manager version " ++ version ++ "\n"
128 usageHeader :: String -> String
129 usageHeader prog = substProg prog $
131 " $p register {filename | -}\n" ++
132 " Register the package using the specified installed package\n" ++
133 " description. The syntax for the latter is given in the $p\n" ++
134 " documentation.\n" ++
136 " $p update {filename | -}\n" ++
137 " Register the package, overwriting any other package with the\n" ++
140 " $p unregister {pkg-id}\n" ++
141 " Unregister the specified package.\n" ++
143 " $p expose {pkg-id}\n" ++
144 " Expose the specified package.\n" ++
146 " $p hide {pkg-id}\n" ++
147 " Hide the specified package.\n" ++
149 " $p list [pkg]\n" ++
150 " List registered packages in the global database, and also the\n" ++
151 " user database if --user is given. If a package name is given\n" ++
152 " all the registered versions will be listed in ascending order.\n" ++
153 " Accepts the --simple-output flag.\n" ++
155 " $p latest pkg\n" ++
156 " Prints the highest registered version of a package.\n" ++
159 " Check the consistency of package depenencies and list broken packages.\n" ++
160 " Accepts the --simple-output flag.\n" ++
162 " $p describe {pkg-id}\n" ++
163 " Give the registered description for the specified package. The\n" ++
164 " description is returned in precisely the syntax required by $p\n" ++
167 " $p field {pkg-id} {field}\n" ++
168 " Extract the specified field of the package description for the\n" ++
169 " specified package.\n" ++
171 " When asked to modify a database (register, unregister, update,\n"++
172 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
173 " default. Specifying --user causes it to act on the user database,\n"++
174 " or --package-conf can be used to act on another database\n"++
175 " entirely. When multiple of these options are given, the rightmost\n"++
176 " one is used as the database to act upon.\n"++
178 " Commands that query the package database (list, latest, describe,\n"++
179 " field) operate on the list of databases specified by the flags\n"++
180 " --user, --global, and --package-conf. If none of these flags are\n"++
181 " given, the default is --global --user.\n"++
183 " The following optional flags are also accepted:\n"
185 substProg :: String -> String -> String
187 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
188 substProg prog (c:xs) = c : substProg prog xs
190 -- -----------------------------------------------------------------------------
193 data Force = ForceAll | ForceFiles | NoForce
195 runit :: [Flag] -> [String] -> IO ()
196 runit cli nonopts = do
197 prog <- getProgramName
200 | FlagForce `elem` cli = ForceAll
201 | FlagForceFiles `elem` cli = ForceFiles
202 | otherwise = NoForce
203 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
205 -- first, parse the command
207 ["register", filename] ->
208 registerPackage filename cli auto_ghci_libs False force
209 ["update", filename] ->
210 registerPackage filename cli auto_ghci_libs True force
211 ["unregister", pkgid_str] -> do
212 pkgid <- readGlobPkgId pkgid_str
213 unregisterPackage pkgid cli
214 ["expose", pkgid_str] -> do
215 pkgid <- readGlobPkgId pkgid_str
216 exposePackage pkgid cli
217 ["hide", pkgid_str] -> do
218 pkgid <- readGlobPkgId pkgid_str
219 hidePackage pkgid cli
221 listPackages cli Nothing Nothing
222 ["list", pkgid_str] -> do
223 pkgid <- readGlobPkgId pkgid_str
224 listPackages cli (Just pkgid) Nothing
225 ["find-module", moduleName] -> do
226 listPackages cli Nothing (Just moduleName)
227 ["latest", pkgid_str] -> do
228 pkgid <- readGlobPkgId pkgid_str
229 latestPackage cli pkgid
230 ["describe", pkgid_str] -> do
231 pkgid <- readGlobPkgId pkgid_str
232 describePackage cli pkgid
233 ["field", pkgid_str, field] -> do
234 pkgid <- readGlobPkgId pkgid_str
235 describeField cli pkgid field
239 die ("missing command\n" ++
240 usageInfo (usageHeader prog) flags)
242 die ("command-line syntax error\n" ++
243 usageInfo (usageHeader prog) flags)
245 parseCheck :: ReadP a a -> String -> String -> IO a
246 parseCheck parser str what =
247 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
249 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
251 readGlobPkgId :: String -> IO PackageIdentifier
252 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
254 parseGlobPackageId :: ReadP r PackageIdentifier
258 (do n <- parsePackageName; string "-*"
259 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
261 -- globVersion means "all versions"
262 globVersion :: Version
263 globVersion = Version{ versionBranch=[], versionTags=["*"] }
265 -- -----------------------------------------------------------------------------
268 -- Some commands operate on a single database:
269 -- register, unregister, expose, hide
270 -- however these commands also check the union of the available databases
271 -- in order to check consistency. For example, register will check that
272 -- dependencies exist before registering a package.
274 -- Some commands operate on multiple databases, with overlapping semantics:
275 -- list, describe, field
277 type PackageDBName = FilePath
278 type PackageDB = [InstalledPackageInfo]
280 type PackageDBStack = [(PackageDBName,PackageDB)]
281 -- A stack of package databases. Convention: head is the topmost
282 -- in the stack. Earlier entries override later one.
284 getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
285 getPkgDatabases modify flags = do
286 -- first we determine the location of the global package config. On Windows,
287 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
288 -- location is passed to the binary using the --global-config flag by the
290 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
292 case [ f | FlagGlobalConfig f <- flags ] of
293 [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
295 Nothing -> die err_msg
296 Just dir -> return (dir </> "package.conf")
297 fs -> return (last fs)
299 let global_conf_dir = global_conf ++ ".d"
300 global_conf_dir_exists <- doesDirectoryExist global_conf_dir
302 if global_conf_dir_exists
303 then do files <- getDirectoryContents global_conf_dir
304 return [ global_conf_dir ++ '/' : file
306 , isSuffixOf ".conf" file]
309 -- get the location of the user package database, and create it if necessary
310 appdir <- getAppUserDataDirectory "ghc"
313 subdir = targetARCH ++ '-':targetOS ++ '-':version
314 archdir = appdir </> subdir
315 user_conf = archdir </> "package.conf"
316 user_exists <- doesFileExist user_conf
318 -- If the user database doesn't exist, and this command isn't a
319 -- "modify" command, then we won't attempt to create or use it.
321 | modify || user_exists = user_conf : global_confs ++ [global_conf]
322 | otherwise = global_confs ++ [global_conf]
324 e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
327 Left _ -> sys_databases
329 | last cs == "" -> init cs ++ sys_databases
331 where cs = splitSearchPath path
333 -- The "global" database is always the one at the bottom of the stack.
334 -- This is the database we modify by default.
335 virt_global_conf = last env_stack
337 let db_flags = [ f | Just f <- map is_db_flag flags ]
338 where is_db_flag FlagUser = Just user_conf
339 is_db_flag FlagGlobal = Just virt_global_conf
340 is_db_flag (FlagConfig f) = Just f
341 is_db_flag _ = Nothing
345 then -- For a "read" command, we use all the databases
346 -- specified on the command line. If there are no
347 -- command-line flags specifying databases, the default
348 -- is to use all the ones we know about.
349 if null db_flags then return env_stack
350 else return (reverse (nub db_flags))
352 -- For a "modify" command, treat all the databases as
353 -- a stack, where we are modifying the top one, but it
354 -- can refer to packages in databases further down the
357 -- -f flags on the command line add to the database
358 -- stack, unless any of them are present in the stack
360 flag_stack = filter (`notElem` env_stack)
361 [ f | FlagConfig f <- reverse flags ]
365 | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
366 | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
369 then modifying virt_global_conf
370 else modifying (head db_flags)
372 db_stack <- mapM readParseDatabase final_stack
375 readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
376 readParseDatabase filename = do
377 str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
378 let packages = read str
379 Exception.evaluate packages
380 `Exception.catch` \_ ->
381 die (filename ++ ": parse error in package config file")
382 return (filename,packages)
384 emptyPackageConfig :: String
385 emptyPackageConfig = "[]"
387 -- -----------------------------------------------------------------------------
390 registerPackage :: FilePath
392 -> Bool -- auto_ghci_libs
396 registerPackage input flags auto_ghci_libs update force = do
397 db_stack <- getPkgDatabases True flags
399 db_to_operate_on = my_head "db" db_stack
400 db_filename = fst db_to_operate_on
406 putStr "Reading package info from stdin ... "
409 putStr ("Reading package info from " ++ show f ++ " ... ")
412 expanded <- expandEnvVars s force
414 pkg <- parsePackageInfo expanded
417 validatePackageConfig pkg db_stack auto_ghci_libs update force
418 let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
419 not_this p = package p /= package pkg
420 savingOldConfig db_filename $
421 writeNewConfig db_filename new_details
425 -> IO InstalledPackageInfo
426 parsePackageInfo str =
427 case parseInstalledPackageInfo str of
428 ParseOk _warns ok -> return ok
429 ParseFailed err -> case locatedErrorMsg err of
430 (Nothing, s) -> die s
431 (Just l, s) -> die (show l ++ ": " ++ s)
433 -- -----------------------------------------------------------------------------
434 -- Exposing, Hiding, Unregistering are all similar
436 exposePackage :: PackageIdentifier -> [Flag] -> IO ()
437 exposePackage = modifyPackage (\p -> [p{exposed=True}])
439 hidePackage :: PackageIdentifier -> [Flag] -> IO ()
440 hidePackage = modifyPackage (\p -> [p{exposed=False}])
442 unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
443 unregisterPackage = modifyPackage (\p -> [])
446 :: (InstalledPackageInfo -> [InstalledPackageInfo])
450 modifyPackage fn pkgid flags = do
451 db_stack <- getPkgDatabases True{-modify-} flags
452 let ((db_name, pkgs) : _) = db_stack
453 ps <- findPackages [(db_name,pkgs)] pkgid
454 let pids = map package ps
455 let new_config = concat (map modify pkgs)
457 | package pkg `elem` pids = fn pkg
459 savingOldConfig db_name $
460 writeNewConfig db_name new_config
462 -- -----------------------------------------------------------------------------
465 listPackages :: [Flag] -> Maybe PackageIdentifier -> Maybe String -> IO ()
466 listPackages flags mPackageName mModuleName = do
467 let simple_output = FlagSimpleOutput `elem` flags
468 db_stack <- getPkgDatabases False flags
469 let db_stack_filtered -- if a package is given, filter out all other packages
470 | Just this <- mPackageName =
471 map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
473 | Just this <- mModuleName = -- packages which expose mModuleName
474 map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs))
476 | otherwise = db_stack
479 = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
480 where sort_pkgs = sortBy cmpPkgIds
481 cmpPkgIds pkg1 pkg2 =
482 case pkgName p1 `compare` pkgName p2 of
485 EQ -> pkgVersion p1 `compare` pkgVersion p2
486 where (p1,p2) = (package pkg1, package pkg2)
488 pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
489 show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
491 show_func (reverse db_stack_sorted)
493 where show_normal pkg_map (db_name,pkg_confs) =
494 hPutStrLn stdout (render $
495 text db_name <> colon $$ nest 4 packages
497 where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
499 | isBrokenPackage p pkg_map = braces doc
501 | otherwise = parens doc
502 where doc = text (showPackageId (package p))
504 show_simple db_stack = do
505 let showPkg = if FlagNamesOnly `elem` flags then pkgName
507 pkgs = map showPkg $ sortBy compPkgIdVer $
508 map package (concatMap snd db_stack)
509 when (null pkgs) $ die "no matches"
510 hPutStrLn stdout $ concat $ intersperse " " pkgs
512 -- -----------------------------------------------------------------------------
513 -- Prints the highest (hidden or exposed) version of a package
515 latestPackage :: [Flag] -> PackageIdentifier -> IO ()
516 latestPackage flags pkgid = do
517 db_stack <- getPkgDatabases False flags
518 ps <- findPackages db_stack pkgid
519 show_pkg (sortBy compPkgIdVer (map package ps))
521 show_pkg [] = die "no matches"
522 show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
524 -- -----------------------------------------------------------------------------
527 describePackage :: [Flag] -> PackageIdentifier -> IO ()
528 describePackage flags pkgid = do
529 db_stack <- getPkgDatabases False flags
530 ps <- findPackages db_stack pkgid
531 mapM_ (putStrLn . showInstalledPackageInfo) ps
533 -- PackageId is can have globVersion for the version
534 findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
535 findPackages db_stack pkgid
536 = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
537 [] -> die ("cannot find package " ++ showPackageId pkgid)
540 all_pkgs = concat (map snd db_stack)
542 matches :: PackageIdentifier -> PackageIdentifier -> Bool
544 = (pkgName pid == pkgName pid')
545 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
547 matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
548 pid `matchesPkg` pkg = pid `matches` package pkg
550 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
551 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
553 exposedInPkg :: String -> InstalledPackageInfo -> Bool
554 moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg
556 -- -----------------------------------------------------------------------------
559 describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
560 describeField flags pkgid field = do
561 db_stack <- getPkgDatabases False flags
562 case toField field of
563 Nothing -> die ("unknown field: " ++ field)
565 ps <- findPackages db_stack pkgid
566 let top_dir = takeDirectory (fst (last db_stack))
567 mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
569 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
570 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
571 -- with the current topdir (obtained from the -B option).
572 mungePackagePaths top_dir ps = map munge_pkg ps
574 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
575 includeDirs = munge_paths (includeDirs p),
576 libraryDirs = munge_paths (libraryDirs p),
577 frameworkDirs = munge_paths (frameworkDirs p),
578 haddockInterfaces = munge_paths (haddockInterfaces p),
579 haddockHTMLs = munge_paths (haddockHTMLs p)
582 munge_paths = map munge_path
585 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
586 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
589 toHttpPath p = "file:///" ++ p
591 maybePrefixMatch :: String -> String -> Maybe String
592 maybePrefixMatch [] rest = Just rest
593 maybePrefixMatch (_:_) [] = Nothing
594 maybePrefixMatch (p:pat) (r:rest)
595 | p == r = maybePrefixMatch pat rest
596 | otherwise = Nothing
598 toField :: String -> Maybe (InstalledPackageInfo -> String)
599 -- backwards compatibility:
600 toField "import_dirs" = Just $ strList . importDirs
601 toField "source_dirs" = Just $ strList . importDirs
602 toField "library_dirs" = Just $ strList . libraryDirs
603 toField "hs_libraries" = Just $ strList . hsLibraries
604 toField "extra_libraries" = Just $ strList . extraLibraries
605 toField "include_dirs" = Just $ strList . includeDirs
606 toField "c_includes" = Just $ strList . includes
607 toField "package_deps" = Just $ strList . map showPackageId. depends
608 toField "extra_cc_opts" = Just $ strList . ccOptions
609 toField "extra_ld_opts" = Just $ strList . ldOptions
610 toField "framework_dirs" = Just $ strList . frameworkDirs
611 toField "extra_frameworks"= Just $ strList . frameworks
612 toField s = showInstalledPackageInfoField s
614 strList :: [String] -> String
618 -- -----------------------------------------------------------------------------
619 -- Check: Check consistency of installed packages
621 checkConsistency :: [Flag] -> IO ()
622 checkConsistency flags = do
623 db_stack <- getPkgDatabases True flags
624 -- check behaves like modify for the purposes of deciding which
625 -- databases to use, because ordering is important.
626 let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
629 let broken_deps = missingPackageDeps p pkgs
630 guard (not . null $ broken_deps)
631 return (pid, broken_deps)
632 mapM_ (putStrLn . render . show_func) broken_pkgs
634 show_func | FlagSimpleOutput `elem` flags = show_simple
635 | otherwise = show_normal
636 show_simple (pid,deps) =
637 text (showPackageId pid) <> colon
638 <+> fsep (punctuate comma (map (text . showPackageId) deps))
639 show_normal (pid,deps) =
640 text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
641 $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
643 missingPackageDeps :: InstalledPackageInfo
644 -> [(PackageIdentifier, InstalledPackageInfo)]
645 -> [PackageIdentifier]
646 missingPackageDeps pkg pkg_map =
647 [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
648 [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
650 isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
651 isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
654 -- -----------------------------------------------------------------------------
655 -- Manipulating package.conf files
657 writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
658 writeNewConfig filename packages = do
659 hPutStr stdout "Writing new package config file... "
660 createDirectoryIfMissing True $ takeDirectory filename
661 h <- openFile filename WriteMode `catch` \e ->
662 if isPermissionError e
663 then die (filename ++ ": you don't have permission to modify this file")
665 let shown = concat $ intersperse ",\n " $ map show packages
666 fileContents = "[" ++ shown ++ "\n]"
667 hPutStrLn h fileContents
669 hPutStrLn stdout "done."
671 savingOldConfig :: FilePath -> IO () -> IO ()
672 savingOldConfig filename io = Exception.block $ do
673 hPutStr stdout "Saving old package config file... "
674 -- mv rather than cp because we've already done an hGetContents
675 -- on this file so we won't be able to open it for writing
676 -- unless we move the old one out of the way...
677 let oldFile = filename ++ ".old"
678 restore_on_error <- catch (renameFile filename oldFile >> return True) $
680 unless (isDoesNotExistError err) $ do
681 hPutStrLn stderr (unwords ["Unable to rename", show filename,
685 hPutStrLn stdout "done."
687 hPutStrLn stderr (show e)
688 hPutStr stdout ("\nWARNING: an error was encountered while writing"
689 ++ "the new configuration.\n")
690 when restore_on_error $ do
691 hPutStr stdout "Attempting to restore the old configuration..."
692 do renameFile oldFile filename
693 hPutStrLn stdout "done."
694 `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
697 -----------------------------------------------------------------------------
698 -- Sanity-check a new package config, and automatically build GHCi libs
701 validatePackageConfig :: InstalledPackageInfo
703 -> Bool -- auto-ghc-libs
707 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
709 checkDuplicates db_stack pkg update force
710 mapM_ (checkDep db_stack force) (depends pkg)
711 mapM_ (checkDir force) (importDirs pkg)
712 mapM_ (checkDir force) (libraryDirs pkg)
713 mapM_ (checkDir force) (includeDirs pkg)
714 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
715 -- ToDo: check these somehow?
716 -- extra_libraries :: [String],
717 -- c_includes :: [String],
719 -- When the package name and version are put together, sometimes we can
720 -- end up with a package id that cannot be parsed. This will lead to
721 -- difficulties when the user wants to refer to the package later, so
722 -- we check that the package id can be parsed properly here.
723 checkPackageId :: InstalledPackageInfo -> IO ()
725 let str = showPackageId (package ipi) in
726 case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
728 [] -> die ("invalid package identifier: " ++ str)
729 _ -> die ("ambiguous package identifier: " ++ str)
731 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO ()
732 checkDuplicates db_stack pkg update force = do
735 (_top_db_name, pkgs) : _ = db_stack
737 -- Check whether this package id already exists in this DB
739 when (not update && (pkgid `elem` map package pkgs)) $
740 die ("package " ++ showPackageId pkgid ++ " is already installed")
743 uncasep = map toLower . showPackageId
744 dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
746 when (not update && not (null dups)) $ dieOrForceAll force $
747 "Package names may be treated case-insensitively in the future.\n"++
748 "Package " ++ showPackageId pkgid ++
749 " overlaps with: " ++ unwords (map showPackageId dups)
752 checkDir :: Force -> String -> IO ()
754 | "$topdir" `isPrefixOf` d = return ()
755 | "$httptopdir" `isPrefixOf` d = return ()
756 -- can't check these, because we don't know what $(http)topdir is
758 there <- doesDirectoryExist d
760 (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
762 checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
763 checkDep db_stack force pkgid
764 | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
765 | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
768 -- for backwards compat, we treat 0.0 as a special version,
769 -- and don't check that it actually exists.
770 real_version = realVersion pkgid
772 name_exists = any (\p -> pkgName (package p) == name) all_pkgs
775 all_pkgs = concat (map snd db_stack)
776 pkgids = map package all_pkgs
778 realVersion :: PackageIdentifier -> Bool
779 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
781 checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
782 checkHSLib dirs auto_ghci_libs force lib = do
783 let batch_lib_file = "lib" ++ lib ++ ".a"
784 bs <- mapM (doesLibExistIn batch_lib_file) dirs
785 case [ dir | (exists,dir) <- zip bs dirs, exists ] of
786 [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
788 (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
790 doesLibExistIn :: String -> String -> IO Bool
792 | "$topdir" `isPrefixOf` d = return True
793 | "$httptopdir" `isPrefixOf` d = return True
794 | otherwise = doesFileExist (d ++ '/':lib)
796 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
797 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
798 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
800 bs <- mapM (doesLibExistIn ghci_lib_file) dirs
801 case [dir | (exists,dir) <- zip bs dirs, exists] of
802 [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
805 ghci_lib_file = lib ++ ".o"
807 -- automatically build the GHCi version of a batch lib,
808 -- using ld --whole-archive.
810 autoBuildGHCiLib :: String -> String -> String -> IO ()
811 autoBuildGHCiLib dir batch_file ghci_file = do
812 let ghci_lib_file = dir ++ '/':ghci_file
813 batch_lib_file = dir ++ '/':batch_file
814 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
815 #if defined(darwin_HOST_OS)
816 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
817 #elif defined(mingw32_HOST_OS)
818 execDir <- getExecDir "/bin/ghc-pkg.exe"
819 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
821 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
823 when (r /= ExitSuccess) $ exitWith r
824 hPutStrLn stderr (" done.")
826 -- -----------------------------------------------------------------------------
827 -- Searching for modules
831 findModules :: [FilePath] -> IO [String]
833 mms <- mapM searchDir paths
836 searchDir path prefix = do
837 fs <- getDirectoryEntries path `catch` \_ -> return []
838 searchEntries path prefix fs
840 searchEntries path prefix [] = return []
841 searchEntries path prefix (f:fs)
842 | looks_like_a_module = do
843 ms <- searchEntries path prefix fs
844 return (prefix `joinModule` f : ms)
845 | looks_like_a_component = do
846 ms <- searchDir (path </> f) (prefix `joinModule` f)
847 ms' <- searchEntries path prefix fs
850 searchEntries path prefix fs
853 (base,suffix) = splitFileExt f
854 looks_like_a_module =
855 suffix `elem` haskell_suffixes &&
856 all okInModuleName base
857 looks_like_a_component =
858 null suffix && all okInModuleName base
864 -- ---------------------------------------------------------------------------
865 -- expanding environment variables in the package configuration
867 expandEnvVars :: String -> Force -> IO String
868 expandEnvVars str force = go str ""
870 go "" acc = return $! reverse acc
871 go ('$':'{':str) acc | (var, '}':rest) <- break close str
872 = do value <- lookupEnvVar var
873 go rest (reverse value ++ acc)
874 where close c = c == '}' || c == '\n' -- don't span newlines
878 lookupEnvVar :: String -> IO String
880 catch (System.getEnv nm)
881 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
885 -----------------------------------------------------------------------------
887 getProgramName :: IO String
888 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
889 where str `withoutSuffix` suff
890 | suff `isSuffixOf` str = take (length str - length suff) str
893 bye :: String -> IO a
894 bye s = putStr s >> exitWith ExitSuccess
896 die :: String -> IO a
899 prog <- getProgramName
900 hPutStrLn stderr (prog ++ ": " ++ s)
901 exitWith (ExitFailure 1)
903 dieOrForceAll :: Force -> String -> IO ()
904 dieOrForceAll ForceAll s = ignoreError s
905 dieOrForceAll _other s = dieForcible s
907 dieOrForceFile :: Force -> String -> IO ()
908 dieOrForceFile ForceAll s = ignoreError s
909 dieOrForceFile ForceFiles s = ignoreError s
910 dieOrForceFile _other s = dieForcible s
912 ignoreError :: String -> IO ()
913 ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
915 dieForcible :: String -> IO ()
916 dieForcible s = die (s ++ " (use --force to override)")
918 my_head :: String -> [a] -> a
919 my_head s [] = error s
922 -----------------------------------------
923 -- Cut and pasted from ghc/compiler/SysTools
925 #if defined(mingw32_HOST_OS)
926 subst :: Char -> Char -> String -> String
927 subst a b ls = map (\ x -> if x == a then b else x) ls
929 unDosifyPath :: FilePath -> FilePath
930 unDosifyPath xs = subst '\\' '/' xs
932 getExecDir :: String -> IO (Maybe String)
933 -- (getExecDir cmd) returns the directory in which the current
934 -- executable, which should be called 'cmd', is running
935 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
936 -- you'll get "/a/b/c" back as the result
938 = allocaArray len $ \buf -> do
939 ret <- getModuleFileName nullPtr buf len
940 if ret == 0 then return Nothing
941 else do s <- peekCString buf
942 return (Just (reverse (drop (length cmd)
943 (reverse (unDosifyPath s)))))
945 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
947 foreign import stdcall unsafe "GetModuleFileNameA"
948 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
950 getExecDir :: String -> IO (Maybe String)
951 getExecDir _ = return Nothing