-----------------------------------------------------------------------------
-- TODO:
--- - validate modules
--- - expanding of variables in new-style package conf
--- - version manipulation (checking whether old version exists,
--- hiding old version?)
+-- * validate modules
+-- * expanding of variables in new-style package conf
+-- * version manipulation (checking whether old version exists,
+-- hiding old version?)
module Main (main) where
-import Version ( version, targetOS, targetARCH )
+import Version ( version, targetOS, targetARCH )
import Distribution.InstalledPackageInfo
import Distribution.Compat.ReadP
-import Distribution.ParseUtils ( showError )
+import Distribution.ParseUtils
import Distribution.Package
import Distribution.Version
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
+import System.FilePath
+
+#ifdef USING_COMPAT
+import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import Compat.RawSystem ( rawSystem )
+#else
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import System.Cmd ( rawSystem )
+#endif
import Prelude
#include "../../includes/ghcconfig.h"
-#if __GLASGOW_HASKELL__ >= 504
import System.Console.GetOpt
import Text.PrettyPrint
import qualified Control.Exception as Exception
import Data.Maybe
-#else
-import GetOpt
-import Pretty
-import qualified Exception
-import Maybe
-#endif
-import Data.Char ( isSpace )
+import Data.Char ( isSpace )
import Monad
import Directory
-import System ( getArgs, getProgName, getEnv,
- exitWith, ExitCode(..)
- )
+import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) )
import System.IO
-#if __GLASGOW_HASKELL__ >= 600
import System.IO.Error (try)
-#else
-import System.IO (try)
-#endif
import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy )
#ifdef mingw32_HOST_OS
import Foreign
-
-#if __GLASGOW_HASKELL__ >= 504
import Foreign.C.String
-#else
-import CString
-#endif
#endif
+import IO ( isPermissionError, isDoesNotExistError )
+
-- -----------------------------------------------------------------------------
-- Entry point
args <- getArgs
case getOpt Permute flags args of
- (cli,_,[]) | FlagHelp `elem` cli -> do
- prog <- getProgramName
- bye (usageInfo (usageHeader prog) flags)
- (cli,_,[]) | FlagVersion `elem` cli ->
- bye ourCopyright
- (cli,nonopts,[]) ->
- runit cli nonopts
- (_,_,errors) -> tryOldCmdLine errors args
+ (cli,_,[]) | FlagHelp `elem` cli -> do
+ prog <- getProgramName
+ bye (usageInfo (usageHeader prog) flags)
+ (cli,_,[]) | FlagVersion `elem` cli ->
+ bye ourCopyright
+ (cli,nonopts,[]) ->
+ runit cli nonopts
+ (_,_,errors) -> tryOldCmdLine errors args
-- If the new command-line syntax fails, then we try the old. If that
-- fails too, then we output the original errors and the new syntax
tryOldCmdLine :: [String] -> [String] -> IO ()
tryOldCmdLine errors args = do
case getOpt Permute oldFlags args of
- (cli@(_:_),[],[]) ->
- oldRunit cli
- _failed -> do
- prog <- getProgramName
- die (concat errors ++ usageInfo (usageHeader prog) flags)
+ (cli@(_:_),[],[]) ->
+ oldRunit cli
+ _failed -> do
+ prog <- getProgramName
+ die (concat errors ++ usageInfo (usageHeader prog) flags)
-- -----------------------------------------------------------------------------
-- Command-line syntax
| FlagGlobal
| FlagHelp
| FlagVersion
- | FlagConfig FilePath
+ | FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagForce
+ | FlagForceFiles
| FlagAutoGHCiLibs
| FlagDefinedName String String
| FlagSimpleOutput
+ | FlagNamesOnly
deriving Eq
flags :: [OptDescr Flag]
flags = [
Option [] ["user"] (NoArg FlagUser)
- "use the current user's package database",
+ "use the current user's package database",
Option [] ["global"] (NoArg FlagGlobal)
- "(default) use the global package database",
+ "(default) use the global package database",
Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
- "act upon specified package config file (only)",
+ "act upon specified package config file (only)",
Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
- "location of the global package config",
+ "location of the global package config",
Option [] ["force"] (NoArg FlagForce)
- "ignore missing dependencies, directories, and libraries",
+ "ignore missing dependencies, directories, and libraries",
+ Option [] ["force-files"] (NoArg FlagForceFiles)
+ "ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
- "automatically build libs for GHCi (with register)",
+ "automatically build libs for GHCi (with register)",
Option ['?'] ["help"] (NoArg FlagHelp)
- "display this help and exit",
+ "display this help and exit",
Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
+ "define NAME as VALUE",
Option ['V'] ["version"] (NoArg FlagVersion)
- "output version information and exit",
+ "output version information and exit",
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
- "print output in easy-to-parse format when running command 'list'"
+ "print output in easy-to-parse format for some commands",
+ Option [] ["names-only"] (NoArg FlagNamesOnly)
+ "only print package names, not versions; can only be used with list --simple-output"
]
where
- toDefined str =
+ toDefined str =
case break (=='=') str of
(nm,[]) -> FlagDefinedName nm []
(nm,_:val) -> FlagDefinedName nm val
" List registered packages in the global database, and also the\n" ++
" user database if --user is given. If a package name is given\n" ++
" all the registered versions will be listed in ascending order.\n" ++
+ " Accepts the --simple-output flag.\n" ++
"\n" ++
" $p latest pkg\n" ++
" Prints the highest registered version of a package.\n" ++
"\n" ++
+ " $p check\n" ++
+ " Check the consistency of package depenencies and list broken packages.\n" ++
+ " Accepts the --simple-output flag.\n" ++
+ "\n" ++
" $p describe {pkg-id}\n" ++
" Give the registered description for the specified package. The\n" ++
" description is returned in precisely the syntax required by $p\n" ++
-- -----------------------------------------------------------------------------
-- Do the business
+data Force = ForceAll | ForceFiles | NoForce
+
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
prog <- getProgramName
let
- force = FlagForce `elem` cli
- auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ force
+ | FlagForce `elem` cli = ForceAll
+ | FlagForceFiles `elem` cli = ForceFiles
+ | otherwise = NoForce
+ auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
--
-- first, parse the command
case nonopts of
- ["register", filename] ->
- registerPackage filename defines cli auto_ghci_libs False force
- ["update", filename] ->
- registerPackage filename defines cli auto_ghci_libs True force
+ ["register", filename] ->
+ registerPackage filename defines cli auto_ghci_libs False force
+ ["update", filename] ->
+ registerPackage filename defines cli auto_ghci_libs True force
["unregister", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- unregisterPackage pkgid cli
+ pkgid <- readGlobPkgId pkgid_str
+ unregisterPackage pkgid cli
["expose", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- exposePackage pkgid cli
+ pkgid <- readGlobPkgId pkgid_str
+ exposePackage pkgid cli
["hide", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- hidePackage pkgid cli
+ pkgid <- readGlobPkgId pkgid_str
+ hidePackage pkgid cli
["list"] -> do
- listPackages cli Nothing
+ listPackages cli Nothing
["list", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just pkgid)
+ pkgid <- readGlobPkgId pkgid_str
+ listPackages cli (Just pkgid)
["latest", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- latestPackage cli pkgid
+ pkgid <- readGlobPkgId pkgid_str
+ latestPackage cli pkgid
["describe", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- describePackage cli pkgid
+ pkgid <- readGlobPkgId pkgid_str
+ describePackage cli pkgid
["field", pkgid_str, field] -> do
- pkgid <- readGlobPkgId pkgid_str
- describeField cli pkgid field
+ pkgid <- readGlobPkgId pkgid_str
+ describeField cli pkgid field
+ ["check"] -> do
+ checkConsistency cli
[] -> do
- die ("missing command\n" ++
- usageInfo (usageHeader prog) flags)
+ die ("missing command\n" ++
+ usageInfo (usageHeader prog) flags)
(_cmd:_) -> do
- die ("command-line syntax error\n" ++
- usageInfo (usageHeader prog) flags)
+ die ("command-line syntax error\n" ++
+ usageInfo (usageHeader prog) flags)
parseCheck :: ReadP a a -> String -> String -> IO a
-parseCheck parser str what =
+parseCheck parser str what =
case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
[x] -> return x
_ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
parseGlobPackageId :: ReadP r PackageIdentifier
-parseGlobPackageId =
+parseGlobPackageId =
parsePackageId
+++
(do n <- parsePackageName; string "-*"
-- Package databases
-- Some commands operate on a single database:
--- register, unregister, expose, hide
+-- register, unregister, expose, hide
-- however these commands also check the union of the available databases
-- in order to check consistency. For example, register will check that
-- dependencies exist before registering a package.
--
-- Some commands operate on multiple databases, with overlapping semantics:
--- list, describe, field
+-- list, describe, field
type PackageDBName = FilePath
type PackageDB = [InstalledPackageInfo]
type PackageDBStack = [(PackageDBName,PackageDB)]
- -- A stack of package databases. Convention: head is the topmost
- -- in the stack. Earlier entries override later one.
+ -- A stack of package databases. Convention: head is the topmost
+ -- in the stack. Earlier entries override later one.
getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
getPkgDatabases modify flags = do
-- location is passed to the binary using the --global-config flag by the
-- wrapper script.
let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
- global_conf <-
+ global_conf <-
case [ f | FlagGlobalConfig f <- flags ] of
- [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
- case mb_dir of
- Nothing -> die err_msg
- Just dir -> return (dir `joinFileName` "package.conf")
+ [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
+ case mb_dir of
+ Nothing -> die err_msg
+ Just dir -> return (dir </> "package.conf")
fs -> return (last fs)
let global_conf_dir = global_conf ++ ".d"
appdir <- getAppUserDataDirectory "ghc"
let
- subdir = targetARCH ++ '-':targetOS ++ '-':version
- archdir = appdir `joinFileName` subdir
- user_conf = archdir `joinFileName` "package.conf"
+ subdir = targetARCH ++ '-':targetOS ++ '-':version
+ archdir = appdir </> subdir
+ user_conf = archdir </> "package.conf"
user_exists <- doesFileExist user_conf
-- If the user database doesn't exist, and this command isn't a
-- "modify" command, then we won't attempt to create or use it.
let sys_databases
- | modify || user_exists = user_conf : global_confs ++ [global_conf]
- | otherwise = global_confs ++ [global_conf]
+ | modify || user_exists = user_conf : global_confs ++ [global_conf]
+ | otherwise = global_confs ++ [global_conf]
e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
let env_stack =
- case e_pkg_path of
- Left _ -> sys_databases
- Right path
- | last cs == "" -> init cs ++ sys_databases
- | otherwise -> cs
- where cs = parseSearchPath path
-
- -- The "global" database is always the one at the bottom of the stack.
- -- This is the database we modify by default.
+ case e_pkg_path of
+ Left _ -> sys_databases
+ Right path
+ | last cs == "" -> init cs ++ sys_databases
+ | otherwise -> cs
+ where cs = splitSearchPath path
+
+ -- The "global" database is always the one at the bottom of the stack.
+ -- This is the database we modify by default.
virt_global_conf = last env_stack
-- -f flags on the command line add to the database stack, unless any
-- of them are present in the stack already.
- let flag_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse flags ] ++ env_stack
+ let flag_stack = filter (`notElem` env_stack)
+ [ f | FlagConfig f <- reverse flags ] ++ env_stack
-- Now we have the full stack of databases. Next, if the current
-- command is a "modify" type command, then we truncate the stack
-- so that the topmost element is the database being modified.
final_stack <-
- if not modify
+ if not modify
then return flag_stack
- else let
- go (FlagUser : fs) = modifying user_conf
- go (FlagGlobal : fs) = modifying virt_global_conf
- go (FlagConfig f : fs) = modifying f
- go (_ : fs) = go fs
- go [] = modifying virt_global_conf
-
- modifying f
- | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
- | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
- in
- go flags
+ else let
+ go (FlagUser : fs) = modifying user_conf
+ go (FlagGlobal : fs) = modifying virt_global_conf
+ go (FlagConfig f : fs) = modifying f
+ go (_ : fs) = go fs
+ go [] = modifying virt_global_conf
+
+ modifying f
+ | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
+ | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
+ in
+ go flags
db_stack <- mapM readParseDatabase final_stack
return db_stack
str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
let packages = read str
Exception.evaluate packages
- `Exception.catch` \_ ->
- die (filename ++ ": parse error in package config file")
+ `Exception.catch` \_ ->
+ die (filename ++ ": parse error in package config file")
return (filename,packages)
emptyPackageConfig :: String
-- Registering
registerPackage :: FilePath
- -> [(String,String)] -- defines
- -> [Flag]
- -> Bool -- auto_ghci_libs
- -> Bool -- update
- -> Bool -- force
- -> IO ()
+ -> [(String,String)] -- defines
+ -> [Flag]
+ -> Bool -- auto_ghci_libs
+ -> Bool -- update
+ -> Force
+ -> IO ()
registerPackage input defines flags auto_ghci_libs update force = do
db_stack <- getPkgDatabases True flags
let
- db_to_operate_on = my_head "db" db_stack
- db_filename = fst db_to_operate_on
+ db_to_operate_on = my_head "db" db_stack
+ db_filename = fst db_to_operate_on
--
- checkConfigAccess db_filename
s <-
case input of
"-" -> do
- putStr "Reading package info from stdin ... "
+ putStr "Reading package info from stdin ... "
getContents
f -> do
putStr ("Reading package info from " ++ show f ++ " ... ")
- readFile f
+ readFile f
expanded <- expandEnvVars s defines force
- pkg0 <- parsePackageInfo expanded defines force
+ pkg0 <- parsePackageInfo expanded defines
putStrLn "done."
let pkg = resolveDeps db_stack pkg0
validatePackageConfig pkg db_stack auto_ghci_libs update force
- let new_details = snd db_to_operate_on ++ [pkg]
- savePackageConfig db_filename
- maybeRestoreOldConfig db_filename $
+ let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
+ not_this p = package p /= package pkg
+ savingOldConfig db_filename $
writeNewConfig db_filename new_details
parsePackageInfo
- :: String
- -> [(String,String)]
- -> Bool
- -> IO InstalledPackageInfo
-parsePackageInfo str defines force =
+ :: String
+ -> [(String,String)]
+ -> IO InstalledPackageInfo
+parsePackageInfo str defines =
case parseInstalledPackageInfo str of
ParseOk _warns ok -> return ok
- ParseFailed err -> die (showError err)
+ ParseFailed err -> case locatedErrorMsg err of
+ (Nothing, s) -> die s
+ (Just l, s) -> die (show l ++ ": " ++ s)
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Unregistering are all similar
modifyPackage fn pkgid flags = do
db_stack <- getPkgDatabases True{-modify-} flags
let ((db_name, pkgs) : _) = db_stack
- checkConfigAccess db_name
ps <- findPackages [(db_name,pkgs)] pkgid
let pids = map package ps
- savePackageConfig db_name
let new_config = concat (map modify pkgs)
modify pkg
- | package pkg `elem` pids = fn pkg
- | otherwise = [pkg]
- maybeRestoreOldConfig db_name $
+ | package pkg `elem` pids = fn pkg
+ | otherwise = [pkg]
+ savingOldConfig db_name $
writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
db_stack <- getPkgDatabases False flags
let db_stack_filtered -- if a package is given, filter out all other packages
| Just this <- mPackageName =
- map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
- db_stack
+ map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
+ db_stack
| otherwise = db_stack
- db_stack_sorted
+ db_stack_sorted
= [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
- where sort_pkgs = sortBy cmpPkgIds
- cmpPkgIds pkg1 pkg2 =
- case pkgName p1 `compare` pkgName p2 of
- LT -> LT
- GT -> GT
- EQ -> pkgVersion p1 `compare` pkgVersion p2
- where (p1,p2) = (package pkg1, package pkg2)
+ where sort_pkgs = sortBy cmpPkgIds
+ cmpPkgIds pkg1 pkg2 =
+ case pkgName p1 `compare` pkgName p2 of
+ LT -> LT
+ GT -> GT
+ EQ -> pkgVersion p1 `compare` pkgVersion p2
+ where (p1,p2) = (package pkg1, package pkg2)
- show_func = if simple_output then show_easy else mapM_ show_regular
+ pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
+ show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
show_func (reverse db_stack_sorted)
- where show_regular (db_name,pkg_confs) =
- hPutStrLn stdout (render $
- text (db_name ++ ":") $$ nest 4 packages
- )
- where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
- pp_pkg p
- | exposed p = doc
- | otherwise = parens doc
- where doc = text (showPackageId (package p))
-
- show_easy db_stack = do
- let pkgs = map showPackageId $ sortBy compPkgIdVer $
+ where show_normal pkg_map (db_name,pkg_confs) =
+ hPutStrLn stdout (render $
+ text db_name <> colon $$ nest 4 packages
+ )
+ where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
+ pp_pkg p
+ | isBrokenPackage p pkg_map = braces doc
+ | exposed p = doc
+ | otherwise = parens doc
+ where doc = text (showPackageId (package p))
+
+ show_simple db_stack = do
+ let showPkg = if FlagNamesOnly `elem` flags then pkgName
+ else showPackageId
+ pkgs = map showPkg $ sortBy compPkgIdVer $
map package (concatMap snd db_stack)
when (null pkgs) $ die "no matches"
hPutStrLn stdout $ concat $ intersperse " " pkgs
findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
findPackages db_stack pkgid
= case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
- ps -> return ps
+ [] -> die ("cannot find package " ++ showPackageId pkgid)
+ ps -> return ps
where
- all_pkgs = concat (map snd db_stack)
+ all_pkgs = concat (map snd db_stack)
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
case toField field of
Nothing -> die ("unknown field: " ++ field)
Just fn -> do
- ps <- findPackages db_stack pkgid
- mapM_ (putStrLn.fn) ps
+ ps <- findPackages db_stack pkgid
+ let top_dir = takeDirectory (fst (last db_stack))
+ mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
+
+mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
+-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
+-- with the current topdir (obtained from the -B option).
+mungePackagePaths top_dir ps = map munge_pkg ps
+ where
+ munge_pkg p = p{ importDirs = munge_paths (importDirs p),
+ includeDirs = munge_paths (includeDirs p),
+ libraryDirs = munge_paths (libraryDirs p),
+ frameworkDirs = munge_paths (frameworkDirs p),
+ haddockInterfaces = munge_paths (haddockInterfaces p),
+ haddockHTMLs = munge_paths (haddockHTMLs p)
+ }
+
+ munge_paths = map munge_path
+
+ munge_path p
+ | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+ | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
+ | otherwise = p
+
+ toHttpPath p = "file:///" ++ p
+
+maybePrefixMatch :: String -> String -> Maybe String
+maybePrefixMatch [] rest = Just rest
+maybePrefixMatch (_:_) [] = Nothing
+maybePrefixMatch (p:pat) (r:rest)
+ | p == r = maybePrefixMatch pat rest
+ | otherwise = Nothing
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
toField "package_deps" = Just $ strList . map showPackageId. depends
toField "extra_cc_opts" = Just $ strList . ccOptions
toField "extra_ld_opts" = Just $ strList . ldOptions
-toField "framework_dirs" = Just $ strList . frameworkDirs
-toField "extra_frameworks"= Just $ strList . frameworks
-toField s = showInstalledPackageInfoField s
+toField "framework_dirs" = Just $ strList . frameworkDirs
+toField "extra_frameworks"= Just $ strList . frameworks
+toField s = showInstalledPackageInfoField s
strList :: [String] -> String
strList = show
+
-- -----------------------------------------------------------------------------
--- Manipulating package.conf files
+-- Check: Check consistency of installed packages
+
+checkConsistency :: [Flag] -> IO ()
+checkConsistency flags = do
+ db_stack <- getPkgDatabases False flags
+ let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
+ broken_pkgs = do
+ (pid, p) <- pkgs
+ let broken_deps = missingPackageDeps p pkgs
+ guard (not . null $ broken_deps)
+ return (pid, broken_deps)
+ mapM_ (putStrLn . render . show_func) broken_pkgs
+ where
+ show_func | FlagSimpleOutput `elem` flags = show_simple
+ | otherwise = show_normal
+ show_simple (pid,deps) =
+ text (showPackageId pid) <> colon
+ <+> fsep (punctuate comma (map (text . showPackageId) deps))
+ show_normal (pid,deps) =
+ text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
+ $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
+
+missingPackageDeps :: InstalledPackageInfo
+ -> [(PackageIdentifier, InstalledPackageInfo)]
+ -> [PackageIdentifier]
+missingPackageDeps pkg pkg_map =
+ [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
+ [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
+
+isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
+isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
-checkConfigAccess :: FilePath -> IO ()
-checkConfigAccess filename = do
- access <- getPermissions filename
- when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file"))
-
-maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
-maybeRestoreOldConfig filename io
- = io `catch` \e -> do
- hPutStrLn stderr (show e)
- hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
- "configuration was being written. Attempting to \n"++
- "restore the old configuration... ")
- renameFile (filename ++ ".old") filename
- hPutStrLn stdout "done."
- ioError e
+
+-- -----------------------------------------------------------------------------
+-- Manipulating package.conf files
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
- h <- openFile filename WriteMode
- hPutStrLn h (show packages)
+ createDirectoryIfMissing True $ takeDirectory filename
+ h <- openFile filename WriteMode `catch` \e ->
+ if isPermissionError e
+ then die (filename ++ ": you don't have permission to modify this file")
+ else ioError e
+ let shown = concat $ intersperse ",\n " $ map show packages
+ fileContents = "[" ++ shown ++ "\n]"
+ hPutStrLn h fileContents
hClose h
hPutStrLn stdout "done."
-savePackageConfig :: FilePath -> IO ()
-savePackageConfig filename = do
+savingOldConfig :: FilePath -> IO () -> IO ()
+savingOldConfig filename io = Exception.block $ do
hPutStr stdout "Saving old package config file... "
-- mv rather than cp because we've already done an hGetContents
-- on this file so we won't be able to open it for writing
-- unless we move the old one out of the way...
let oldFile = filename ++ ".old"
- doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
- when doesExist (removeFile oldFile `catch` (const $ return ()))
- catch (renameFile filename oldFile)
- (\ err -> do
- hPutStrLn stderr (unwords [ "Unable to rename "
- , show filename
- , " to "
- , show oldFile
- ])
- ioError err)
+ restore_on_error <- catch (renameFile filename oldFile >> return True) $
+ \err -> do
+ unless (isDoesNotExistError err) $ do
+ hPutStrLn stderr (unwords ["Unable to rename", show filename,
+ "to", show oldFile])
+ ioError err
+ return False
hPutStrLn stdout "done."
+ io `catch` \e -> do
+ hPutStrLn stderr (show e)
+ hPutStr stdout ("\nWARNING: an error was encountered while writing"
+ ++ "the new configuration.\n")
+ when restore_on_error $ do
+ hPutStr stdout "Attempting to restore the old configuration..."
+ do renameFile oldFile filename
+ hPutStrLn stdout "done."
+ `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
+ ioError e
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.
validatePackageConfig :: InstalledPackageInfo
- -> PackageDBStack
- -> Bool -- auto-ghc-libs
- -> Bool -- update
- -> Bool -- force
- -> IO ()
+ -> PackageDBStack
+ -> Bool -- auto-ghc-libs
+ -> Bool -- update
+ -> Force
+ -> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
checkPackageId pkg
- checkDuplicates db_stack pkg update force
- mapM_ (checkDep db_stack force) (depends pkg)
- mapM_ (checkDir force) (importDirs pkg)
- mapM_ (checkDir force) (libraryDirs pkg)
- mapM_ (checkDir force) (includeDirs pkg)
+ checkDuplicates db_stack pkg update
+ mapM_ (checkDep db_stack force) (depends pkg)
+ mapM_ (checkDir force) (importDirs pkg)
+ mapM_ (checkDir force) (libraryDirs pkg)
+ mapM_ (checkDir force) (includeDirs pkg)
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
-- ToDo: check these somehow?
- -- extra_libraries :: [String],
- -- c_includes :: [String],
+ -- extra_libraries :: [String],
+ -- c_includes :: [String],
-- When the package name and version are put together, sometimes we can
--- end up with a package id that cannot be parsed. This will lead to
+-- end up with a package id that cannot be parsed. This will lead to
-- difficulties when the user wants to refer to the package later, so
-- we check that the package id can be parsed properly here.
checkPackageId :: InstalledPackageInfo -> IO ()
resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo
resolveDeps db_stack p = updateDeps p
where
- -- The input package spec is allowed to give a package dependency
- -- without a version number; e.g.
- -- depends: base
- -- Here, we update these dependencies without version numbers to
- -- match the actual versions of the relevant packages installed.
- updateDeps p = p{depends = map resolveDep (depends p)}
-
- resolveDep dep_pkgid
- | realVersion dep_pkgid = dep_pkgid
- | otherwise = lookupDep dep_pkgid
-
- lookupDep dep_pkgid
- = let
- name = pkgName dep_pkgid
- in
- case [ pid | p <- concat (map snd db_stack),
- let pid = package p,
- pkgName pid == name ] of
- (pid:_) -> pid -- Found installed package,
- -- replete with its version
- [] -> dep_pkgid -- No installed package; use
- -- the version-less one
-
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO ()
-checkDuplicates db_stack pkg update force = do
+ -- The input package spec is allowed to give a package dependency
+ -- without a version number; e.g.
+ -- depends: base
+ -- Here, we update these dependencies without version numbers to
+ -- match the actual versions of the relevant packages installed.
+ updateDeps p = p{depends = map resolveDep (depends p)}
+
+ resolveDep dep_pkgid
+ | realVersion dep_pkgid = dep_pkgid
+ | otherwise = lookupDep dep_pkgid
+
+ lookupDep dep_pkgid
+ = let
+ name = pkgName dep_pkgid
+ in
+ case [ pid | p <- concat (map snd db_stack),
+ let pid = package p,
+ pkgName pid == name ] of
+ (pid:_) -> pid -- Found installed package,
+ -- replete with its version
+ [] -> dep_pkgid -- No installed package; use
+ -- the version-less one
+
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
+checkDuplicates db_stack pkg update = do
let
- pkgid = package pkg
- (_top_db_name, pkgs) : _ = db_stack
+ pkgid = package pkg
+ (_top_db_name, pkgs) : _ = db_stack
--
-- Check whether this package id already exists in this DB
--
-checkDir :: Bool -> String -> IO ()
+checkDir :: Force -> String -> IO ()
checkDir force d
- | "$topdir" `isPrefixOf` d = return ()
- -- can't check this, because we don't know what $topdir is
+ | "$topdir" `isPrefixOf` d = return ()
+ | "$httptopdir" `isPrefixOf` d = return ()
+ -- can't check these, because we don't know what $(http)topdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
+ (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
-checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
+checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
- | not real_version || pkgid `elem` pkgids = return ()
- | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
- ++ " doesn't exist")
+ | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
+ | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
+ ++ " doesn't exist")
where
- -- for backwards compat, we treat 0.0 as a special version,
- -- and don't check that it actually exists.
- real_version = realVersion pkgid
-
- all_pkgs = concat (map snd db_stack)
- pkgids = map package all_pkgs
+ -- for backwards compat, we treat 0.0 as a special version,
+ -- and don't check that it actually exists.
+ real_version = realVersion pkgid
+
+ name_exists = any (\p -> pkgName (package p) == name) all_pkgs
+ name = pkgName pkgid
+
+ all_pkgs = concat (map snd db_stack)
+ pkgids = map package all_pkgs
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
+checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
checkHSLib dirs auto_ghci_libs force lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
bs <- mapM (doesLibExistIn batch_lib_file) dirs
case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
- " on library path")
- (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
+ [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
+ " on library path")
+ (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
doesLibExistIn :: String -> String -> IO Bool
doesLibExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
+ | "$topdir" `isPrefixOf` d = return True
+ | "$httptopdir" `isPrefixOf` d = return True
| otherwise = doesFileExist (d ++ '/':lib)
checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
bs <- mapM (doesLibExistIn ghci_lib_file) dirs
case [dir | (exists,dir) <- zip bs dirs, exists] of
[] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
- (_:_) -> return ()
+ (_:_) -> return ()
where
ghci_lib_file = lib ++ ".o"
--- automatically build the GHCi version of a batch lib,
+-- automatically build the GHCi version of a batch lib,
-- using ld --whole-archive.
autoBuildGHCiLib :: String -> String -> String -> IO ()
#if not_yet
findModules :: [FilePath] -> IO [String]
-findModules paths =
+findModules paths =
mms <- mapM searchDir paths
return (concat mms)
searchEntries path prefix [] = return []
searchEntries path prefix (f:fs)
| looks_like_a_module = do
- ms <- searchEntries path prefix fs
- return (prefix `joinModule` f : ms)
+ ms <- searchEntries path prefix fs
+ return (prefix `joinModule` f : ms)
| looks_like_a_component = do
- ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f)
+ ms <- searchDir (path </> f) (prefix `joinModule` f)
ms' <- searchEntries path prefix fs
- return (ms ++ ms')
+ return (ms ++ ms')
| otherwise
- searchEntries path prefix fs
+ searchEntries path prefix fs
where
- (base,suffix) = splitFileExt f
- looks_like_a_module =
- suffix `elem` haskell_suffixes &&
- all okInModuleName base
- looks_like_a_component =
- null suffix && all okInModuleName base
+ (base,suffix) = splitFileExt f
+ looks_like_a_module =
+ suffix `elem` haskell_suffixes &&
+ all okInModuleName base
+ looks_like_a_component =
+ null suffix && all okInModuleName base
okInModuleName c
-- -----------------------------------------------------------------------------
-- The old command-line syntax, supported for backwards compatibility
-data OldFlag
+data OldFlag
= OF_Config FilePath
| OF_Input FilePath
| OF_List
| OF_ListLocal
| OF_Add Bool {- True => replace existing info -}
- | OF_Remove String | OF_Show String
+ | OF_Remove String | OF_Show String
| OF_Field String | OF_AutoGHCiLibs | OF_Force
| OF_DefinedName String String
| OF_GlobalConfig FilePath
isAction OF_Field{} = False
isAction OF_Input{} = False
isAction OF_AutoGHCiLibs{} = False
-isAction OF_Force{} = False
+isAction OF_Force{} = False
isAction OF_DefinedName{} = False
isAction OF_GlobalConfig{} = False
isAction _ = True
oldFlags :: [OptDescr OldFlag]
oldFlags = [
Option ['f'] ["config-file"] (ReqArg OF_Config "FILE")
- "use the specified package config file",
+ "use the specified package config file",
Option ['l'] ["list-packages"] (NoArg OF_List)
- "list packages in all config files",
+ "list packages in all config files",
Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal)
- "list packages in the specified config file",
+ "list packages in the specified config file",
Option ['a'] ["add-package"] (NoArg (OF_Add False))
- "add a new package",
+ "add a new package",
Option ['u'] ["update-package"] (NoArg (OF_Add True))
- "update package with new configuration",
+ "update package with new configuration",
Option ['i'] ["input-file"] (ReqArg OF_Input "FILE")
- "read new package info from specified file",
+ "read new package info from specified file",
Option ['s'] ["show-package"] (ReqArg OF_Show "NAME")
- "show the configuration for package NAME",
+ "show the configuration for package NAME",
Option [] ["field"] (ReqArg OF_Field "FIELD")
- "(with --show-package) Show field FIELD only",
+ "(with --show-package) Show field FIELD only",
Option [] ["force"] (NoArg OF_Force)
- "ignore missing directories/libraries",
+ "ignore missing directories/libraries",
Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME")
- "remove an installed package",
+ "remove an installed package",
Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs)
- "automatically build libs for GHCi (with -a)",
+ "automatically build libs for GHCi (with -a)",
Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
+ "define NAME as VALUE",
Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE")
- "location of the global package config"
+ "location of the global package config"
]
where
- toDefined str =
+ toDefined str =
case break (=='=') str of
(nm,[]) -> OF_DefinedName nm []
(nm,_:val) -> OF_DefinedName nm val
conv (OF_Config f) = Just (FlagConfig f)
conv _ = Nothing
-
+
let fields = [ f | OF_Field f <- clis ]
- let auto_ghci_libs = any isAuto clis
- where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
+ let auto_ghci_libs = any isAuto clis
+ where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
- force = OF_Force `elem` clis
-
+ force = if OF_Force `elem` clis then ForceAll else NoForce
+
defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
case [ c | c <- clis, isAction c ] of
[ OF_List ] -> listPackages new_flags Nothing
[ OF_ListLocal ] -> listPackages new_flags Nothing
- [ OF_Add upd ] ->
- registerPackage input_file defines new_flags auto_ghci_libs upd force
+ [ OF_Add upd ] ->
+ registerPackage input_file defines new_flags auto_ghci_libs upd force
[ OF_Remove pkgid_str ] -> do
- pkgid <- readPkgId pkgid_str
- unregisterPackage pkgid new_flags
+ pkgid <- readPkgId pkgid_str
+ unregisterPackage pkgid new_flags
[ OF_Show pkgid_str ]
- | null fields -> do
- pkgid <- readPkgId pkgid_str
- describePackage new_flags pkgid
- | otherwise -> do
- pkgid <- readPkgId pkgid_str
- mapM_ (describeField new_flags pkgid) fields
- _ -> do
- prog <- getProgramName
- die (usageInfo (usageHeader prog) flags)
+ | null fields -> do
+ pkgid <- readPkgId pkgid_str
+ describePackage new_flags pkgid
+ | otherwise -> do
+ pkgid <- readPkgId pkgid_str
+ mapM_ (describeField new_flags pkgid) fields
+ _ -> do
+ prog <- getProgramName
+ die (usageInfo (usageHeader prog) flags)
my_head :: String -> [a] -> a
my_head s [] = error s
-- ---------------------------------------------------------------------------
-- expanding environment variables in the package configuration
-expandEnvVars :: String -> [(String, String)] -> Bool -> IO String
+expandEnvVars :: String -> [(String, String)] -> Force -> IO String
expandEnvVars str defines force = go str ""
where
go "" acc = return $! reverse acc
go ('$':'{':str) acc | (var, '}':rest) <- break close str
= do value <- lookupEnvVar var
- go rest (reverse value ++ acc)
- where close c = c == '}' || c == '\n' -- don't span newlines
+ go rest (reverse value ++ acc)
+ where close c = c == '}' || c == '\n' -- don't span newlines
go (c:str) acc
- = go str (c:acc)
+ = go str (c:acc)
lookupEnvVar :: String -> IO String
- lookupEnvVar nm =
+ lookupEnvVar nm =
case lookup nm defines of
Just x | not (null x) -> return x
- _ ->
- catch (System.getEnv nm)
- (\ _ -> do dieOrForce force ("Unable to expand variable " ++
- show nm)
- return "")
+ _ ->
+ catch (System.getEnv nm)
+ (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
+ show nm)
+ return "")
-----------------------------------------------------------------------------
bye s = putStr s >> exitWith ExitSuccess
die :: String -> IO a
-die s = do
+die s = do
hFlush stdout
prog <- getProgramName
hPutStrLn stderr (prog ++ ": " ++ s)
exitWith (ExitFailure 1)
-dieOrForce :: Bool -> String -> IO ()
-dieOrForce force s
- | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ " (use --force to override)")
+dieOrForceAll :: Force -> String -> IO ()
+dieOrForceAll ForceAll s = ignoreError s
+dieOrForceAll _other s = dieForcible s
+
+dieOrForceFile :: Force -> String -> IO ()
+dieOrForceFile ForceAll s = ignoreError s
+dieOrForceFile ForceFiles s = ignoreError s
+dieOrForceFile _other s = dieForcible s
+
+ignoreError :: String -> IO ()
+ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
+
+dieForcible :: String -> IO ()
+dieForcible s = die (s ++ " (use --force to override)")
-----------------------------------------
--- Cut and pasted from ghc/compiler/SysTools
+-- Cut and pasted from ghc/compiler/SysTools
#if defined(mingw32_HOST_OS)
+subst :: Char -> Char -> String -> String
subst a b ls = map (\ x -> if x == a then b else x) ls
+
+unDosifyPath :: FilePath -> FilePath
unDosifyPath xs = subst '\\' '/' xs
getExecDir :: String -> IO (Maybe String)
-- (getExecDir cmd) returns the directory in which the current
--- executable, which should be called 'cmd', is running
+-- executable, which should be called 'cmd', is running
-- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
-- you'll get "/a/b/c" back as the result
getExecDir cmd
= allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else do s <- peekCString buf
- return (Just (reverse (drop (length cmd)
- (reverse (unDosifyPath s)))))
+ ret <- getModuleFileName nullPtr buf len
+ if ret == 0 then return Nothing
+ else do s <- peekCString buf
+ return (Just (reverse (drop (length cmd)
+ (reverse (unDosifyPath s)))))
where
len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
-getExecDir :: String -> IO (Maybe String)
+getExecDir :: String -> IO (Maybe String)
getExecDir _ = return Nothing
#endif
-
--- -----------------------------------------------------------------------------
--- FilePath utils
-
--- | The 'joinFileName' function is the opposite of 'splitFileName'.
--- It joins directory and file names to form a complete file path.
---
--- The general rule is:
---
--- > dir `joinFileName` basename == path
--- > where
--- > (dir,basename) = splitFileName path
---
--- There might be an exceptions to the rule but in any case the
--- reconstructed path will refer to the same object (file or directory).
--- An example exception is that on Windows some slashes might be converted
--- to backslashes.
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
--- | Checks whether the character is a valid path separator for the host
--- platform. The valid character is a 'pathSeparator' but since the Windows
--- operating system also accepts a slash (\"\/\") since DOS 2, the function
--- checks for it on this platform, too.
-isPathSeparator :: Char -> Bool
-isPathSeparator ch = ch == pathSeparator || ch == '/'
-
--- | Provides a platform-specific character used to separate directory levels in
--- a path string that reflects a hierarchical file system organization. The
--- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
--- (@\"\\\"@) on the Windows operating system.
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
--- | The function splits the given string to substrings
--- using the 'searchPathSeparator'.
-parseSearchPath :: String -> [FilePath]
-parseSearchPath path = split path
- where
- split :: String -> [String]
- split s =
- case rest' of
- [] -> [chunk]
- _:rest -> chunk : split rest
- where
- chunk =
- case chunk' of
-#ifdef mingw32_HOST_OS
- ('\"':xs@(_:_)) | last xs == '\"' -> init xs
-#endif
- _ -> chunk'
-
- (chunk', rest') = break (==searchPathSeparator) s
-
--- | A platform-specific character used to separate search path strings in
--- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
--- and a semicolon (\";\") on the Windows operating system.
-searchPathSeparator :: Char
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-searchPathSeparator = ';'
-#else
-searchPathSeparator = ':'
-#endif
-