-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS -fglasgow-exts -cpp #-}
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004.
module Main (main) where
import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo
+import Distribution.InstalledPackageInfo hiding (depends)
import Distribution.Compat.ReadP
import Distribution.ParseUtils
import Distribution.Package
+import Distribution.Text
import Distribution.Version
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 System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import Prelude
import Data.Char ( isSpace, toLower )
import Control.Monad
-import System.Directory ( doesDirectoryExist, getDirectoryContents,
+import System.Directory ( doesDirectoryExist, getDirectoryContents,
doesFileExist, renameFile, removeFile )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
import System.IO.Error (try)
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub )
+import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub,
+ unfoldr, break )
+#if __GLASGOW_HASKELL__ > 604
+import Data.List ( isInfixOf )
+#else
+import Data.List ( tails )
+#endif
import Control.Concurrent
#ifdef mingw32_HOST_OS
import IO ( isPermissionError, isDoesNotExistError )
+#if defined(GLOB)
+import System.Process(runInteractiveCommand)
+import qualified System.Info(os)
+#endif
+
-- -----------------------------------------------------------------------------
-- Entry point
| FlagAutoGHCiLibs
| FlagSimpleOutput
| FlagNamesOnly
+ | FlagIgnoreCase
deriving Eq
flags :: [OptDescr Flag]
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
"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"
+ "only print package names, not versions; can only be used with list --simple-output",
+ Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
+ "ignore case for substring matching"
]
deprecFlags :: [OptDescr Flag]
" all the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
- " $p latest pkg\n" ++
+ " $p find-module {module}\n" ++
+ " List registered packages exposing module {module} in the global\n" ++
+ " database, and also the user database if --user is given.\n" ++
+ " All the registered versions will be listed in ascending order.\n" ++
+ " Accepts the --simple-output flag.\n" ++
+ "\n" ++
+ " $p latest {pkg-id}\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" ++
+ " $p describe {pkg}\n" ++
" Give the registered description for the specified package. The\n" ++
" description is returned in precisely the syntax required by $p\n" ++
" register.\n" ++
"\n" ++
- " $p field {pkg-id} {field}\n" ++
+ " $p field {pkg} {field}\n" ++
" Extract the specified field of the package description for the\n" ++
- " specified package.\n" ++
+ " specified package. Accepts comma-separated multiple fields.\n" ++
+ "\n" ++
+ " $p dump\n" ++
+ " Dump the registered description for every package. This is like\n" ++
+ " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
+ " by tools that parse the results, rather than humans.\n" ++
+ "\n" ++
+ " Substring matching is supported for {module} in find-module and\n" ++
+ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
+ " open substring ends (prefix*, *suffix, *infix*).\n" ++
"\n" ++
" When asked to modify a database (register, unregister, update,\n"++
" hide, expose, and also check), ghc-pkg modifies the global database by\n"++
data Force = ForceAll | ForceFiles | NoForce
+data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
+
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
installSignalHandlers -- catch ^C and clean up
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ splitFields fields = unfoldr splitComma (',':fields)
+ where splitComma "" = Nothing
+ splitComma fs = Just $ break (==',') (tail fs)
+
+ substringCheck :: String -> Maybe (String -> Bool)
+ substringCheck "" = Nothing
+ substringCheck "*" = Just (const True)
+ substringCheck [_] = Nothing
+ substringCheck (h:t) =
+ case (h, init t, last t) of
+ ('*',s,'*') -> Just (isInfixOf (f s) . f)
+ ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
+ ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
+ _ -> Nothing
+ where f | FlagIgnoreCase `elem` cli = map toLower
+ | otherwise = id
+#if defined(GLOB)
+ glob x | System.Info.os=="mingw32" = do
+ -- glob echoes its argument, after win32 filename globbing
+ (_,o,_,_) <- runInteractiveCommand ("glob "++x)
+ txt <- hGetContents o
+ return (read txt)
+ glob x | otherwise = return [x]
+#endif
--
-- first, parse the command
case nonopts of
+#if defined(GLOB)
+ -- dummy command to demonstrate usage and permit testing
+ -- without messing things up; use glob to selectively enable
+ -- windows filename globbing for file parameters
+ -- register, update, FlagGlobalConfig, FlagConfig; others?
+ ["glob", filename] -> do
+ print filename
+ glob filename >>= print
+#endif
["register", filename] ->
registerPackage filename cli auto_ghci_libs False force
["update", filename] ->
hidePackage pkgid cli
["list"] -> do
listPackages cli Nothing Nothing
- ["list", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just pkgid) Nothing
+ ["list", pkgid_str] ->
+ case substringCheck pkgid_str of
+ Nothing -> do pkgid <- readGlobPkgId pkgid_str
+ listPackages cli (Just (Id pkgid)) Nothing
+ Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing
["find-module", moduleName] -> do
- listPackages cli Nothing (Just moduleName)
+ let match = maybe (==moduleName) id (substringCheck moduleName)
+ listPackages cli Nothing (Just match)
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage cli pkgid
- ["describe", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- describePackage cli pkgid
- ["field", pkgid_str, field] -> do
- pkgid <- readGlobPkgId pkgid_str
- describeField cli pkgid field
+ ["describe", pkgid_str] ->
+ case substringCheck pkgid_str of
+ Nothing -> do pkgid <- readGlobPkgId pkgid_str
+ describePackage cli (Id pkgid)
+ Just m -> describePackage cli (Substring pkgid_str m)
+ ["field", pkgid_str, fields] ->
+ case substringCheck pkgid_str of
+ Nothing -> do pkgid <- readGlobPkgId pkgid_str
+ describeField cli (Id pkgid) (splitFields fields)
+ Just m -> describeField cli (Substring pkgid_str m)
+ (splitFields fields)
["check"] -> do
checkConsistency cli
+
+ ["dump"] -> do
+ dumpPackages cli
+
[] -> do
die ("missing command\n" ++
usageInfo (usageHeader prog) flags)
parseGlobPackageId :: ReadP r PackageIdentifier
parseGlobPackageId =
- parsePackageId
+ parse
+++
- (do n <- parsePackageName; string "-*"
+ (do n <- parse
+ string "-*"
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
-- globVersion means "all versions"
-- A stack of package databases. Convention: head is the topmost
-- in the stack. Earlier entries override later one.
+allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
+allPackagesInStack = concatMap snd
+
getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
-getPkgDatabases modify flags = do
+getPkgDatabases modify my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-- 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 <-
- case [ f | FlagGlobalConfig f <- flags ] of
+ case [ f | FlagGlobalConfig f <- my_flags ] of
[] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
case mb_dir of
Nothing -> die err_msg
- Just dir -> return (dir </> "package.conf")
+ Just dir ->
+ do let path1 = dir </> "package.conf"
+ path2 = dir </> ".." </> ".." </> ".."
+ </> "inplace-datadir"
+ </> "package.conf"
+ exists1 <- doesFileExist path1
+ exists2 <- doesFileExist path2
+ if exists1 then return path1
+ else if exists2 then return path2
+ else die "Can't find package.conf"
fs -> return (last fs)
let global_conf_dir = global_conf ++ ".d"
-- This is the database we modify by default.
virt_global_conf = last env_stack
- let db_flags = [ f | Just f <- map is_db_flag flags ]
+ let db_flags = [ f | Just f <- map is_db_flag my_flags ]
where is_db_flag FlagUser = Just user_conf
is_db_flag FlagGlobal = Just virt_global_conf
is_db_flag (FlagConfig f) = Just f
-- stack, unless any of them are present in the stack
-- already.
flag_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse flags ]
+ [ f | FlagConfig f <- reverse my_flags ]
++ env_stack
modifying f
readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
readParseDatabase filename = do
- str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
- let packages = read str
+ str <- readFile filename `catchIO` \_ -> return emptyPackageConfig
+ let packages = map convertPackageInfoIn $ read str
Exception.evaluate packages
- `Exception.catch` \e->
+ `catchError` \e->
die ("error while parsing " ++ filename ++ ": " ++ show e)
return (filename,packages)
-> Bool -- update
-> Force
-> IO ()
-registerPackage input flags auto_ghci_libs update force = do
- db_stack <- getPkgDatabases True flags
+registerPackage input my_flags auto_ghci_libs update force = do
+ db_stack <- getPkgDatabases True my_flags
let
db_to_operate_on = my_head "db" db_stack
db_filename = fst db_to_operate_on
hidePackage = modifyPackage (\p -> [p{exposed=False}])
unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
-unregisterPackage = modifyPackage (\p -> [])
+unregisterPackage = modifyPackage (\_ -> [])
modifyPackage
:: (InstalledPackageInfo -> [InstalledPackageInfo])
-> PackageIdentifier
-> [Flag]
-> IO ()
-modifyPackage fn pkgid flags = do
- db_stack <- getPkgDatabases True{-modify-} flags
+modifyPackage fn pkgid my_flags = do
+ db_stack <- getPkgDatabases True{-modify-} my_flags
let ((db_name, pkgs) : _) = db_stack
- ps <- findPackages [(db_name,pkgs)] pkgid
+ ps <- findPackages [(db_name,pkgs)] (Id pkgid)
let pids = map package ps
let new_config = concat (map modify pkgs)
modify pkg
-- -----------------------------------------------------------------------------
-- Listing packages
-listPackages :: [Flag] -> Maybe PackageIdentifier -> Maybe String -> IO ()
-listPackages flags mPackageName mModuleName = do
- let simple_output = FlagSimpleOutput `elem` flags
- db_stack <- getPkgDatabases False flags
+listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
+listPackages my_flags mPackageName mModuleName = do
+ let simple_output = FlagSimpleOutput `elem` my_flags
+ db_stack <- getPkgDatabases False my_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
- | Just this <- mModuleName = -- packages which expose mModuleName
- map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs))
+ | Just match <- mModuleName = -- packages which expose mModuleName
+ map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs))
db_stack
| otherwise = db_stack
EQ -> pkgVersion p1 `compare` pkgVersion p2
where (p1,p2) = (package pkg1, package pkg2)
- pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
+ match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
+
+ pkg_map = map (\p -> (package p, p)) $ allPackagesInStack db_stack
show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
show_func (reverse db_stack_sorted)
| isBrokenPackage p pkg_map = braces doc
| exposed p = doc
| otherwise = parens doc
- where doc = text (showPackageId (package p))
+ where doc = text (display (package p))
show_simple db_stack = do
- let showPkg = if FlagNamesOnly `elem` flags then pkgName
- else showPackageId
+ let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
+ else display
pkgs = map showPkg $ sortBy compPkgIdVer $
- map package (concatMap snd db_stack)
+ map package (allPackagesInStack db_stack)
when (not (null pkgs)) $
hPutStrLn stdout $ concat $ intersperse " " pkgs
-- Prints the highest (hidden or exposed) version of a package
latestPackage :: [Flag] -> PackageIdentifier -> IO ()
-latestPackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
+latestPackage my_flags pkgid = do
+ db_stack <- getPkgDatabases False my_flags
+ ps <- findPackages db_stack (Id pkgid)
show_pkg (sortBy compPkgIdVer (map package ps))
where
show_pkg [] = die "no matches"
- show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
+ show_pkg pids = hPutStrLn stdout (display (last pids))
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: [Flag] -> PackageIdentifier -> IO ()
-describePackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
- mapM_ (putStrLn . showInstalledPackageInfo) ps
+describePackage :: [Flag] -> PackageArg -> IO ()
+describePackage my_flags pkgarg = do
+ db_stack <- getPkgDatabases False my_flags
+ ps <- findPackages db_stack pkgarg
+ doDump ps
+
+dumpPackages :: [Flag] -> IO ()
+dumpPackages my_flags = do
+ db_stack <- getPkgDatabases False my_flags
+ doDump (allPackagesInStack db_stack)
+
+doDump :: [InstalledPackageInfo] -> IO ()
+doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
-- PackageId is can have globVersion for the version
-findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
-findPackages db_stack pkgid
- = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
+findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
+findPackages db_stack pkgarg
+ = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of
+ [] -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg)
ps -> return ps
where
- all_pkgs = concat (map snd db_stack)
+ all_pkgs = allPackagesInStack db_stack
+ pkg_msg (Id pkgid) = display pkgid
+ pkg_msg (Substring pkgpat _) = "matching "++pkgpat
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
= (pkgName pid == pkgName pid')
&& (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
-matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
-pid `matchesPkg` pkg = pid `matches` package pkg
+matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
+(Id pid) `matchesPkg` pkg = pid `matches` package pkg
+(Substring _ m) `matchesPkg` pkg = m (display (package pkg))
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
-exposedInPkg :: String -> InstalledPackageInfo -> Bool
-moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg
-
-- -----------------------------------------------------------------------------
-- Field
-describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
-describeField flags pkgid field = do
- db_stack <- getPkgDatabases False flags
- case toField field of
- Nothing -> die ("unknown field: " ++ field)
- Just fn -> do
- ps <- findPackages db_stack pkgid
- let top_dir = takeDirectory (fst (last db_stack))
- mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
+describeField :: [Flag] -> PackageArg -> [String] -> IO ()
+describeField my_flags pkgarg fields = do
+ db_stack <- getPkgDatabases False my_flags
+ fns <- toFields fields
+ ps <- findPackages db_stack pkgarg
+ let top_dir = takeDirectory (fst (last db_stack))
+ mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+ where toFields [] = return []
+ toFields (f:fs) = case toField f of
+ Nothing -> die ("unknown field: " ++ f)
+ Just fn -> do fns <- toFields fs
+ return (fn:fns)
+ selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
toField "extra_libraries" = Just $ strList . extraLibraries
toField "include_dirs" = Just $ strList . includeDirs
toField "c_includes" = Just $ strList . includes
-toField "package_deps" = Just $ strList . map showPackageId. depends
+toField "package_deps" = Just $ strList . map display. depends
toField "extra_cc_opts" = Just $ strList . ccOptions
toField "extra_ld_opts" = Just $ strList . ldOptions
toField "framework_dirs" = Just $ strList . frameworkDirs
-- Check: Check consistency of installed packages
checkConsistency :: [Flag] -> IO ()
-checkConsistency flags = do
- db_stack <- getPkgDatabases True flags
+checkConsistency my_flags = do
+ db_stack <- getPkgDatabases True my_flags
-- check behaves like modify for the purposes of deciding which
-- databases to use, because ordering is important.
- let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
+ let pkgs = map (\p -> (package p, p)) $ allPackagesInStack db_stack
broken_pkgs = do
(pid, p) <- pkgs
let broken_deps = missingPackageDeps p pkgs
return (pid, broken_deps)
mapM_ (putStrLn . render . show_func) broken_pkgs
where
- show_func | FlagSimpleOutput `elem` flags = show_simple
+ show_func | FlagSimpleOutput `elem` my_flags = show_simple
| otherwise = show_normal
show_simple (pid,deps) =
- text (showPackageId pid) <> colon
- <+> fsep (punctuate comma (map (text . showPackageId) deps))
+ text (display pid) <> colon
+ <+> fsep (punctuate comma (map (text . display) deps))
show_normal (pid,deps) =
- text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
- $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
+ text "package" <+> text (display pid) <+> text "has missing dependencies:"
+ $$ nest 4 (fsep (punctuate comma (map (text . display) 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]
+ [ 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
-
+isBrokenPackage pkg pkg_map
+ = not . null $ missingPackageDeps pkg (filter notme pkg_map)
+ where notme (p, _ipi) = package pkg /= p
+ -- remove p from the database when we invoke missingPackageDeps,
+ -- because we want mutually recursive groups of package to show up
+ -- as broken. (#1750)
-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
+type InstalledPackageInfoString = InstalledPackageInfo_ String
+
+convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
+convertPackageInfoOut
+ (pkgconf@(InstalledPackageInfo { exposedModules = e,
+ hiddenModules = h })) =
+ pkgconf{ exposedModules = map display e,
+ hiddenModules = map display h }
+
+convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
+convertPackageInfoIn
+ (pkgconf@(InstalledPackageInfo { exposedModules = e,
+ hiddenModules = h })) =
+ pkgconf{ exposedModules = map convert e,
+ hiddenModules = map convert h }
+ where convert = fromJust . simpleParse
+
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
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
+ let shown = concat $ intersperse ",\n "
+ $ map (show . convertPackageInfoOut) packages
fileContents = "[" ++ shown ++ "\n]"
hPutStrLn h fileContents
hClose h
ioError err
return False
(do hPutStrLn stdout "done."; io)
- `Exception.catch` \e -> do
+ `onException` do
hPutStr stdout ("WARNING: an error was encountered while writing "
++ "the new configuration.\n")
- if restore_on_error
- then do
+ -- remove any partially complete new version:
+ removeFile filename `catchIO` \_ -> return ()
+ -- and attempt to restore the old one, if we had one:
+ 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)
- else do
- -- file did not exist before, so the new one which
- -- might be partially complete.
- try (removeFile filename)
- return ()
- Exception.throwIO e
+ `catchIO` \err -> hPutStrLn stdout ("Failed: " ++ show err)
+ -- Note the above renameFile sometimes fails on Windows with
+ -- "permission denied", I have no idea why --SDM.
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- we check that the package id can be parsed properly here.
checkPackageId :: InstalledPackageInfo -> IO ()
checkPackageId ipi =
- let str = showPackageId (package ipi) in
- case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
+ let str = display (package ipi) in
+ case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
[_] -> return ()
[] -> die ("invalid package identifier: " ++ str)
_ -> die ("ambiguous package identifier: " ++ str)
-- Check whether this package id already exists in this DB
--
when (not update && (pkgid `elem` map package pkgs)) $
- die ("package " ++ showPackageId pkgid ++ " is already installed")
+ die ("package " ++ display pkgid ++ " is already installed")
let
- uncasep = map toLower . showPackageId
+ uncasep = map toLower . display
dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
when (not update && not (null dups)) $ dieOrForceAll force $
"Package names may be treated case-insensitively in the future.\n"++
- "Package " ++ showPackageId pkgid ++
- " overlaps with: " ++ unwords (map showPackageId dups)
+ "Package " ++ display pkgid ++
+ " overlaps with: " ++ unwords (map display dups)
checkDir :: Force -> String -> IO ()
checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
| pkgid `elem` pkgids || (not real_version && name_exists) = return ()
- | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
+ | otherwise = dieOrForceAll force ("dependency " ++ display pkgid
++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
name_exists = any (\p -> pkgName (package p) == name) all_pkgs
name = pkgName pkgid
- all_pkgs = concat (map snd db_stack)
+ all_pkgs = allPackagesInStack db_stack
pkgids = map package all_pkgs
realVersion :: PackageIdentifier -> Bool
-- expanding environment variables in the package configuration
expandEnvVars :: String -> Force -> IO String
-expandEnvVars str force = go str ""
+expandEnvVars str0 force = go str0 ""
where
go "" acc = return $! reverse acc
go ('$':'{':str) acc | (var, '}':rest) <- break close str
bye s = putStr s >> exitWith ExitSuccess
die :: String -> IO a
-die s = do
+die = dieWith 1
+
+dieWith :: Int -> String -> IO a
+dieWith ec s = do
hFlush stdout
prog <- getProgramName
hPutStrLn stderr (prog ++ ": " ++ s)
- exitWith (ExitFailure 1)
+ exitWith (ExitFailure ec)
dieOrForceAll :: Force -> String -> IO ()
dieOrForceAll ForceAll s = ignoreError s
dieForcible s = die (s ++ " (use --force to override)")
my_head :: String -> [a] -> a
-my_head s [] = error s
-my_head s (x:xs) = x
+my_head s [] = error s
+my_head _ (x : _) = x
-----------------------------------------
-- Cut and pasted from ghc/compiler/main/SysTools
#else
return () -- nothing
#endif
+
+#if __GLASGOW_HASKELL__ <= 604
+isInfixOf :: (Eq a) => [a] -> [a] -> Bool
+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
+#endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#if __GLASGOW_HASKELL__ >= 609
+catchIO = Exception.catch
+#else
+catchIO io handler = io `Exception.catch` handler'
+ where handler' (Exception.IOException ioe) = handler ioe
+ handler' e = Exception.throw e
+#endif
+
+catchError :: IO a -> (String -> IO a) -> IO a
+#if __GLASGOW_HASKELL__ >= 609
+catchError io handler = io `Exception.catch` handler'
+ where handler' (Exception.ErrorCall err) = handler err
+#else
+catchError io handler = io `Exception.catch` handler'
+ where handler' (Exception.ErrorCall err) = handler err
+ handler' e = Exception.throw e
+#endif
+
+onException :: IO a -> IO () -> IO a
+#if __GLASGOW_HASKELL__ >= 609
+onException = Exception.onException
+#else
+onException io what = io `Exception.catch` \e -> do what
+ Exception.throw e
+#endif
+