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
+ 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)] (Id pkgid)
let pids = map package ps
-- Listing packages
listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
-listPackages flags mPackageName mModuleName = do
- let simple_output = FlagSimpleOutput `elem` flags
- db_stack <- getPkgDatabases False flags
+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))
where doc = text (display (package p))
show_simple db_stack = do
- let showPkg = if FlagNamesOnly `elem` flags then display . pkgName
- else display
+ let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
+ else display
pkgs = map showPkg $ sortBy compPkgIdVer $
map package (allPackagesInStack db_stack)
when (not (null pkgs)) $
-- Prints the highest (hidden or exposed) version of a package
latestPackage :: [Flag] -> PackageIdentifier -> IO ()
-latestPackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
+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
-- Describe
describePackage :: [Flag] -> PackageArg -> IO ()
-describePackage flags pkgarg = do
- db_stack <- getPkgDatabases False flags
+describePackage my_flags pkgarg = do
+ db_stack <- getPkgDatabases False my_flags
ps <- findPackages db_stack pkgarg
doDump ps
dumpPackages :: [Flag] -> IO ()
-dumpPackages flags = do
- db_stack <- getPkgDatabases False flags
+dumpPackages my_flags = do
+ db_stack <- getPkgDatabases False my_flags
doDump (allPackagesInStack db_stack)
doDump :: [InstalledPackageInfo] -> IO ()
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
findPackages db_stack pkgarg
= case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of
- [] -> die ("cannot find package " ++ pkg_msg pkgarg)
+ [] -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg)
ps -> return ps
where
all_pkgs = allPackagesInStack db_stack
-- Field
describeField :: [Flag] -> PackageArg -> [String] -> IO ()
-describeField flags pkgarg fields = do
- db_stack <- getPkgDatabases False flags
+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))
-- 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)) $ allPackagesInStack db_stack
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 (display pid) <> colon
isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
isBrokenPackage pkg pkg_map
= not . null $ missingPackageDeps pkg (filter notme pkg_map)
- where notme (p,ipi) = package pkg /= p
+ 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)
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")
-- remove any partially complete new version:
- try (removeFile filename)
+ 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)
+ `catchIO` \err -> hPutStrLn stdout ("Failed: " ++ show err)
-- Note the above renameFile sometimes fails on Windows with
-- "permission denied", I have no idea why --SDM.
- Exception.throwIO e
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- 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
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
+
projects / ghc-hetmet.git / blobdiff