import System.IO
import System.IO.Error (try)
import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub,
- unfoldr, break )
+ unfoldr, break, partition )
#if __GLASGOW_HASKELL__ > 604
import Data.List ( isInfixOf )
#else
registerPackage filename cli auto_ghci_libs True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- unregisterPackage pkgid cli
+ unregisterPackage pkgid cli force
["expose", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- exposePackage pkgid cli
+ exposePackage pkgid cli force
["hide", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- hidePackage pkgid cli
+ hidePackage pkgid cli force
["list"] -> do
listPackages cli Nothing Nothing
["list", pkgid_str] ->
[] -> 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"
else return []
-- get the location of the user package database, and create it if necessary
- appdir <- getAppUserDataDirectory "ghc"
-
- let
- subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
- archdir = appdir </> subdir
- user_conf = archdir </> "package.conf"
- user_exists <- doesFileExist user_conf
+ -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
+ appdir <- try $ getAppUserDataDirectory "ghc"
+
+ mb_user_conf <-
+ case appdir of
+ Right dir -> do
+ let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
+ user_conf = dir </> subdir </> "package.conf"
+ user_exists <- doesFileExist user_conf
+ return (Just (user_conf,user_exists))
+ Left ex ->
+ return Nothing
-- 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]
+ | Just (user_conf,user_exists) <- mb_user_conf,
+ modify || user_exists = user_conf : global_confs ++ [global_conf]
| otherwise = global_confs ++ [global_conf]
e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
virt_global_conf = last env_stack
let db_flags = [ f | Just f <- map is_db_flag my_flags ]
- where is_db_flag FlagUser = Just user_conf
+ where is_db_flag FlagUser
+ | Just (user_conf,user_exists) <- mb_user_conf
+ = Just user_conf
is_db_flag FlagGlobal = Just virt_global_conf
is_db_flag (FlagConfig f) = Just f
is_db_flag _ = Nothing
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)
validatePackageConfig pkg db_stack auto_ghci_libs update force
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
+ writeNewConfig db_filename new_details
parsePackageInfo
:: String
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Unregistering are all similar
-exposePackage :: PackageIdentifier -> [Flag] -> IO ()
+exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
exposePackage = modifyPackage (\p -> [p{exposed=True}])
-hidePackage :: PackageIdentifier -> [Flag] -> IO ()
+hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
hidePackage = modifyPackage (\p -> [p{exposed=False}])
-unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
+unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
unregisterPackage = modifyPackage (\_ -> [])
modifyPackage
:: (InstalledPackageInfo -> [InstalledPackageInfo])
-> PackageIdentifier
-> [Flag]
+ -> Force
-> IO ()
-modifyPackage fn pkgid my_flags = do
+modifyPackage fn pkgid my_flags force = do
db_stack <- getPkgDatabases True{-modify-} my_flags
- let ((db_name, pkgs) : _) = db_stack
+ let old_broken = brokenPackages (allPackagesInStack db_stack)
+ let ((db_name, pkgs) : rest_of_stack) = db_stack
ps <- findPackages [(db_name,pkgs)] (Id pkgid)
let pids = map package ps
let new_config = concat (map modify pkgs)
modify pkg
| package pkg `elem` pids = fn pkg
| otherwise = [pkg]
- savingOldConfig db_name $
- writeNewConfig db_name new_config
+ let new_stack = (db_name,new_config) : rest_of_stack
+ new_broken = map package (brokenPackages (allPackagesInStack new_stack))
+ newly_broken = filter (`notElem` map package old_broken) new_broken
+
+ when (not (null newly_broken)) $
+ dieOrForceAll force ("unregistering " ++ display pkgid ++
+ " would break the following packages: "
+ ++ unwords (map display newly_broken))
+
+ writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
-- Listing packages
match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
- pkg_map = map (\p -> (package p, p)) $ allPackagesInStack db_stack
+ pkg_map = allPackagesInStack db_stack
show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
show_func (reverse db_stack_sorted)
text db_name <> colon $$ nest 4 packages
)
where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
+ broken = map package (brokenPackages pkg_map)
pp_pkg p
- | isBrokenPackage p pkg_map = braces doc
+ | package p `elem` broken = braces doc
| exposed p = doc
| otherwise = parens doc
where doc = text (display (package p))
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
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
- 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
+ let pkgs = allPackagesInStack db_stack
+ broken_pkgs = brokenPackages pkgs
+ broken_ids = map package broken_pkgs
+ broken_why = [ (package p, filter (`elem` broken_ids) (depends p))
+ | p <- broken_pkgs ]
+ mapM_ (putStrLn . render . show_func) broken_why
where
show_func | FlagSimpleOutput `elem` my_flags = show_simple
| otherwise = show_normal
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]
-
-isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
-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
+
+brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+brokenPackages pkgs = go [] pkgs
+ where
+ go avail not_avail =
+ case partition (depsAvailable avail) not_avail of
+ ([], not_avail) -> not_avail
+ (new_avail, not_avail) -> go (new_avail ++ avail) not_avail
+
+ depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
+ -> Bool
+ depsAvailable pkgs_ok pkg = null dangling
+ where dangling = filter (`notElem` pids) (depends pkg)
+ pids = map package pkgs_ok
+
+ -- 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
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
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