diff --git a/Cabal/ChangeLog.md b/Cabal/ChangeLog.md
index 3b5b40db043737b44fb30542c798e2342679217a..8894df09744b447ddb634fdd033d483ba9db439c 100644
--- a/Cabal/ChangeLog.md
+++ b/Cabal/ChangeLog.md
@@ -22,6 +22,7 @@
* Add `Distribution.Compat.Process` with `enableProcessJobs`
* Disallow spaces around colon `:` in Dependency (`build-depends` syntax
* Make `configure` accept any `pkg-config --modversion` output
+ * `IO` actions in `UserHooks` no longer have a `HasCallStack` constraint
# 3.0.1.0 TBW
* Add GHC-8.8 flags to normaliseGhcFlags
diff --git a/Cabal/Distribution/Compat/ResponseFile.hs b/Cabal/Distribution/Compat/ResponseFile.hs
index 5ddfe57b99bb47898e7e71efdd790502b1f8a67d..ddf5f5695e117b8bbf73057e1c253283a711bb07 100644
--- a/Cabal/Distribution/Compat/ResponseFile.hs
+++ b/Cabal/Distribution/Compat/ResponseFile.hs
@@ -56,13 +56,15 @@ expandResponse = go recursionLimit "."
recursionLimit = 100
go :: Int -> FilePath -> [String] -> IO [String]
- go n dir
- | n >= 0 = fmap concat . mapM (expand n dir)
- | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure
+ go n dir xs
+ | n >= 0 = fmap concat $ mapM (\x -> expand n dir x) xs
+ | otherwise = hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure
expand :: Int -> FilePath -> String -> IO [String]
expand n dir arg@('@':f) = readRecursively n (dir </> f) `catchIOError` (const $ print "?" >> return [arg])
expand _n _dir x = return [x]
readRecursively :: Int -> FilePath -> IO [String]
- readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f
+ readRecursively n f = do
+ xs <- unescapeArgs <$> readFile f
+ go (n - 1) (takeDirectory f) xs
diff --git a/Cabal/Distribution/FieldGrammar/FieldDescrs.hs b/Cabal/Distribution/FieldGrammar/FieldDescrs.hs
index 803ce603c0249e7baf012a3594e1be0878861de2..f58a918af59940a83dc1684bac72805534ce8790 100644
--- a/Cabal/Distribution/FieldGrammar/FieldDescrs.hs
+++ b/Cabal/Distribution/FieldGrammar/FieldDescrs.hs
@@ -45,7 +45,7 @@ fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m
-- | Lookup a field value parser.
fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s)
-fieldDescrParse (F m) fn = pParse <$> Map.lookup fn m
+fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m
fieldDescrsToList
:: P.CabalParsing m
diff --git a/Cabal/Distribution/Fields/ParseResult.hs b/Cabal/Distribution/Fields/ParseResult.hs
index 52965e2ea3d70ca5169b505602210c84310878bf..33ce269a1d9169702406a4d4a9de7faae1879188 100644
--- a/Cabal/Distribution/Fields/ParseResult.hs
+++ b/Cabal/Distribution/Fields/ParseResult.hs
@@ -177,9 +177,9 @@ parseString
-> IO a
parseString parser verbosity name bs = do
let (warnings, result) = runParseResult (parser bs)
- traverse_ (warn verbosity . showPWarning name) warnings
+ traverse_ (\warning -> warn verbosity $ showPWarning name warning) warnings
case result of
Right x -> return x
Left (_, errors) -> do
- traverse_ (warn verbosity . showPError name) errors
+ traverse_ (\warning -> warn verbosity $ showPError name warning) errors
die' verbosity $ "Failed parsing \"" ++ name ++ "\"."
diff --git a/Cabal/Distribution/Make.hs b/Cabal/Distribution/Make.hs
index cde201eb9c27b736fd7b4d397eb4267bcc92c333..63e0549560d15481fe6a5b14ac7381f460e79a7a 100644
--- a/Cabal/Distribution/Make.hs
+++ b/Cabal/Distribution/Make.hs
@@ -82,8 +82,10 @@ import Distribution.Pretty
import System.Environment (getArgs, getProgName)
import System.Exit
+import qualified Prelude (IO)
+
defaultMain :: IO ()
-defaultMain = getArgs >>= defaultMainArgs
+defaultMain = getArgs >>= \args -> defaultMainArgs args
defaultMainArgs :: [String] -> IO ()
defaultMainArgs = defaultMainHelper
@@ -114,6 +116,9 @@ defaultMainHelper args =
++ prettyShow cabalVersion
progs = defaultProgramDb
+ -- N.B. Use (Prelude.IO ()) instead of (HasCallStack => IO ()) to avoid
+ -- impredicativity.
+ commands :: [Command (Prelude.IO ())]
commands =
[configureCommand progs `commandAddAction` configureAction
,buildCommand progs `commandAddAction` buildAction
@@ -126,7 +131,9 @@ defaultMainHelper args =
,unregisterCommand `commandAddAction` unregisterAction
]
-configureAction :: ConfigFlags -> [String] -> IO ()
+type Action flags = flags -> [String] -> Prelude.IO ()
+
+configureAction :: Action ConfigFlags
configureAction flags args = do
noExtraFlags args
let verbosity = fromFlag (configVerbosity flags)
@@ -135,7 +142,7 @@ configureAction flags args = do
: configureArgs backwardsCompatHack flags
where backwardsCompatHack = True
-copyAction :: CopyFlags -> [String] -> IO ()
+copyAction :: Action CopyFlags
copyAction flags args = do
noExtraFlags args
let destArgs = case fromFlag $ copyDest flags of
@@ -145,40 +152,40 @@ copyAction flags args = do
rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs
-installAction :: InstallFlags -> [String] -> IO ()
+installAction :: Action InstallFlags
installAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]
rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"]
-haddockAction :: HaddockFlags -> [String] -> IO ()
+haddockAction :: Action HaddockFlags
haddockAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]
`catchIO` \_ ->
rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]
-buildAction :: BuildFlags -> [String] -> IO ()
+buildAction :: Action BuildFlags
buildAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ buildVerbosity flags) "make" []
-cleanAction :: CleanFlags -> [String] -> IO ()
+cleanAction :: Action CleanFlags
cleanAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"]
-sdistAction :: SDistFlags -> [String] -> IO ()
+sdistAction :: Action SDistFlags
sdistAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]
-registerAction :: RegisterFlags -> [String] -> IO ()
+registerAction :: Action RegisterFlags
registerAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]
-unregisterAction :: RegisterFlags -> [String] -> IO ()
+unregisterAction :: Action RegisterFlags
unregisterAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]
diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs
index d6e221f323d1422b35b61b77ed0242e36b15ceeb..514822ae835fa19a2f3cd499c37561b4e2569064 100644
--- a/Cabal/Distribution/Simple.hs
+++ b/Cabal/Distribution/Simple.hs
@@ -670,7 +670,7 @@ autoconfUserHooks
preUnreg = readHook regVerbosity regDistPref
}
where defaultPostConf :: Args -> ConfigFlags -> PackageDescription
- -> LocalBuildInfo -> IO ()
+ -> LocalBuildInfo -> Prelude.IO ()
defaultPostConf args flags pkg_descr lbi
= do let verbosity = fromFlag (configVerbosity flags)
baseDir lbi' = fromMaybe ""
@@ -692,7 +692,7 @@ autoconfUserHooks
readHookWithArgs :: (a -> Flag Verbosity)
-> (a -> Flag FilePath)
-> Args -> a
- -> IO HookedBuildInfo
+ -> Prelude.IO HookedBuildInfo
readHookWithArgs get_verbosity get_dist_pref _ flags = do
dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
getHookedBuildInfo verbosity (dist_dir </> "build")
@@ -701,7 +701,7 @@ autoconfUserHooks
readHook :: (a -> Flag Verbosity)
-> (a -> Flag FilePath)
- -> Args -> a -> IO HookedBuildInfo
+ -> Args -> a -> Prelude.IO HookedBuildInfo
readHook get_verbosity get_dist_pref a flags = do
noExtraFlags a
dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
diff --git a/Cabal/Distribution/Simple/Bench.hs b/Cabal/Distribution/Simple/Bench.hs
index ab76e69e2f77afcd490d2f78d5ddcbdf6fa38357..e352dd262d951fd8771ac88b3d859bb729cebff6 100644
--- a/Cabal/Distribution/Simple/Bench.hs
+++ b/Cabal/Distribution/Simple/Bench.hs
@@ -35,6 +35,7 @@ import Distribution.Pretty
import System.Exit ( ExitCode(..), exitFailure, exitSuccess )
import System.Directory ( doesFileExist )
import System.FilePath ( (</>), (<.>) )
+import qualified Prelude (IO)
-- | Perform the \"@.\/setup bench@\" action.
bench :: Args -- ^positional command-line arguments
@@ -49,7 +50,7 @@ bench args pkg_descr lbi flags = do
enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)
-- Run the benchmark
- doBench :: PD.Benchmark -> IO ExitCode
+ doBench :: PD.Benchmark -> Prelude.IO ExitCode
doBench bm =
case PD.benchmarkInterface bm of
PD.BenchmarkExeV10 _ _ -> do
diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs
index af74f13c02b3abce3d85657fb30c96184dfa5e4a..ee997a37db0f1126bc415cd87631c7594a7171c3 100644
--- a/Cabal/Distribution/Simple/Configure.hs
+++ b/Cabal/Distribution/Simple/Configure.hs
@@ -146,6 +146,7 @@ import Distribution.Compat.Environment ( lookupEnv )
import Distribution.Compat.Exception ( catchExit, catchIO )
import qualified Data.Set as Set
+import qualified Prelude (IO)
type UseExternalInternalDeps = Bool
@@ -229,25 +230,25 @@ getConfigStateFile filename = do
-- info.
tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.
-> IO (Either ConfigStateFileError LocalBuildInfo)
-tryGetConfigStateFile = try . getConfigStateFile
+tryGetConfigStateFile path = try $ getConfigStateFile path
-- | Try to read the 'localBuildInfoFile'.
tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
-> IO (Either ConfigStateFileError LocalBuildInfo)
-tryGetPersistBuildConfig = try . getPersistBuildConfig
+tryGetPersistBuildConfig path = try $ getPersistBuildConfig path
-- | Read the 'localBuildInfoFile'. Throw an exception if the file is
-- missing, if the file cannot be read, or if the file was created by an older
-- version of Cabal.
getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
-> IO LocalBuildInfo
-getPersistBuildConfig = getConfigStateFile . localBuildInfoFile
+getPersistBuildConfig path = getConfigStateFile $ localBuildInfoFile path
-- | Try to read the 'localBuildInfoFile'.
maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
-> IO (Maybe LocalBuildInfo)
-maybeGetPersistBuildConfig =
- liftM (either (const Nothing) Just) . tryGetPersistBuildConfig
+maybeGetPersistBuildConfig path =
+ liftM (either (const Nothing) Just) $ tryGetPersistBuildConfig path
-- | After running configure, output the 'LocalBuildInfo' to the
-- 'localBuildInfoFile'.
@@ -452,10 +453,11 @@ configure (pkg_descr0, pbi) cfg = do
-- version of a dependency, and the executable to use another.
(allConstraints :: [Dependency],
requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo)
- <- either (die' verbosity) return $
- combinedConstraints (configConstraints cfg)
- (configDependencies cfg)
- installedPackageSet
+ <- case combinedConstraints (configConstraints cfg)
+ (configDependencies cfg)
+ installedPackageSet of
+ Left err -> die' verbosity err
+ Right r -> return r
-- pkg_descr: The resolved package description, that does not contain any
-- conditionals, because we have have an assignment for
@@ -590,9 +592,9 @@ configure (pkg_descr0, pbi) cfg = do
, Nothing == desugarBuildTool pkg_descr buildTool ]
externBuildToolDeps ++ unknownBuildTools
- programDb' <-
- configureAllKnownPrograms (lessVerbose verbosity) programDb
- >>= configureRequiredPrograms verbosity requiredBuildTools
+ programDb' <- do
+ progs <- configureAllKnownPrograms (lessVerbose verbosity) programDb
+ configureRequiredPrograms verbosity requiredBuildTools progs
(pkg_descr', programDb'') <-
configurePkgconfigPackages verbosity pkg_descr programDb' enabled
@@ -1532,7 +1534,7 @@ configureRequiredPrograms verbosity deps progdb =
-- program matches the required version; otherwise we will accept
-- any version of the program and assume that it is a simpleProgram.
configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency
- -> IO ProgramDb
+ -> Prelude.IO ProgramDb
configureRequiredProgram verbosity progdb
(LegacyExeDependency progName verRange) =
case lookupKnownProgram progName progdb of
@@ -1952,7 +1954,7 @@ checkPackageProblems verbosity dir gpkg pkg = do
errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]
warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ]
if null errors
- then traverse_ (warn verbosity) warnings
+ then traverse_ (\w -> warn verbosity w) warnings
else die' verbosity (intercalate "\n\n" errors)
-- | Preform checks if a relocatable build is allowed
diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs
index abad0b2bb52f170048166edb59e78d55959c7cdc..faef60c2f6ce6322cf585ac8deb3273fccfa8a94 100644
--- a/Cabal/Distribution/Simple/GHC.hs
+++ b/Cabal/Distribution/Simple/GHC.hs
@@ -123,6 +123,7 @@ import qualified System.Info
#ifndef mingw32_HOST_OS
import System.Posix (createSymbolicLink)
#endif /* mingw32_HOST_OS */
+import qualified Prelude (IO)
-- -----------------------------------------------------------------------------
-- Configuring
@@ -454,10 +455,10 @@ getInstalledPackagesMonitorFiles :: Verbosity -> Platform
-> ProgramDb
-> [PackageDB]
-> IO [FilePath]
-getInstalledPackagesMonitorFiles verbosity platform progdb =
- traverse getPackageDBPath
+getInstalledPackagesMonitorFiles verbosity platform progdb pkgdbs =
+ traverse getPackageDBPath pkgdbs
where
- getPackageDBPath :: PackageDB -> IO FilePath
+ getPackageDBPath :: PackageDB -> Prelude.IO FilePath
getPackageDBPath GlobalPackageDB =
selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg
@@ -1993,9 +1994,9 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do
installOrdinary = install False
installShared = install True
- copyModuleFiles ext =
- findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi)
- >>= installOrdinaryFiles verbosity targetDir
+ copyModuleFiles ext = do
+ files <- findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi)
+ installOrdinaryFiles verbosity targetDir files
compiler_id = compilerId (compiler lbi)
platform = hostPlatform lbi
@@ -2050,6 +2051,7 @@ registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot verbosity lbi = pkgRoot'
where
+ pkgRoot' :: PackageDB -> IO FilePath
pkgRoot' GlobalPackageDB =
let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi)
in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)
diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs
index aa1b791a67f7f0560f78030c8fbe0d4b5773fbaa..95fc597dad0265c748fbb01cdd000387d6c96ff2 100644
--- a/Cabal/Distribution/Simple/GHC/Internal.hs
+++ b/Cabal/Distribution/Simple/GHC/Internal.hs
@@ -97,11 +97,11 @@ configureToolchain :: GhcImplInfo
configureToolchain _implInfo ghcProg ghcInfo =
addKnownProgram gccProgram {
programFindLocation = findProg gccProgramName extraGccPath,
- programPostConf = configureGcc
+ programPostConf = \v cpgm -> configureGcc v cpgm
}
. addKnownProgram ldProgram {
programFindLocation = findProg ldProgramName extraLdPath,
- programPostConf = configureLd
+ programPostConf = \v cpgm -> configureLd v cpgm
}
. addKnownProgram arProgram {
programFindLocation = findProg arProgramName extraArPath
diff --git a/Cabal/Distribution/Simple/GHCJS.hs b/Cabal/Distribution/Simple/GHCJS.hs
index 4ad5bb18cf0b4bdc5c41ffe08fecc590b78d0728..3c7687db95a8bdd62f6d02f99028ab8c9d98e079 100644
--- a/Cabal/Distribution/Simple/GHCJS.hs
+++ b/Cabal/Distribution/Simple/GHCJS.hs
@@ -84,6 +84,7 @@ import System.FilePath ( (</>), (<.>), takeExtension
, takeDirectory, replaceExtension
,isRelative )
import qualified System.Info
+import qualified Prelude (IO)
-- -----------------------------------------------------------------------------
-- Configuring
@@ -339,10 +340,10 @@ getInstalledPackagesMonitorFiles :: Verbosity -> Platform
-> ProgramDb
-> [PackageDB]
-> IO [FilePath]
-getInstalledPackagesMonitorFiles verbosity platform progdb =
- traverse getPackageDBPath
+getInstalledPackagesMonitorFiles verbosity platform progdb pkgdb =
+ traverse getPackageDBPath pkgdb
where
- getPackageDBPath :: PackageDB -> IO FilePath
+ getPackageDBPath :: PackageDB -> Prelude.IO FilePath
getPackageDBPath GlobalPackageDB =
selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg
@@ -1719,9 +1720,9 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do
installOrdinary = install False True
installShared = install True True
- copyModuleFiles ext =
- findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi)
- >>= installOrdinaryFiles verbosity targetDir
+ copyModuleFiles ext = do
+ files <- findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi)
+ installOrdinaryFiles verbosity targetDir files
compiler_id = compilerId (compiler lbi)
platform = hostPlatform lbi
@@ -1799,6 +1800,7 @@ registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot verbosity lbi = pkgRoot'
where
+ pkgRoot' :: PackageDB -> IO FilePath
pkgRoot' GlobalPackageDB =
let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi)
in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)
diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs
index 41040e21f3b6692c8ddd8db04b071e20f6c3fbac..21bd694705c72e9ca7d729ccfb9600658c8649c9 100644
--- a/Cabal/Distribution/Simple/Haddock.hs
+++ b/Cabal/Distribution/Simple/Haddock.hs
@@ -318,7 +318,7 @@ haddock pkg_descr lbi suffixes flags' = do
for_ (extraDocFiles pkg_descr) $ \ fpath -> do
files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
- for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
+ for_ files $ \f -> copyFileTo verbosity (unDir $ argOutputDir commonArgs) f
-- ------------------------------------------------------------------------------
-- Contributions to HaddockArgs (see also Doctest.hs for very similar code).
@@ -501,7 +501,7 @@ getInterfaces :: Verbosity
-> IO HaddockArgs
getInterfaces verbosity lbi clbi htmlTemplate = do
(packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate
- traverse_ (warn (verboseUnmarkOutput verbosity)) warnings
+ traverse_ (\w -> warn (verboseUnmarkOutput verbosity) w) warnings
return $ mempty {
argInterfaces = packageFlags
}
@@ -833,10 +833,13 @@ hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
-hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =
- either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<
- lookupProgramVersion verbosity hscolourProgram
+hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = do
+ result <- lookupProgramVersion verbosity hscolourProgram
(orLaterVersion (mkVersion [1,8])) (withPrograms lbi)
+ case result of
+ Left err -> onNoHsColour err
+ Right (hscolourProg, _, _) -> go hscolourProg
+
where
go :: ConfiguredProgram -> IO ()
go hscolourProg = do
diff --git a/Cabal/Distribution/Simple/PreProcess.hs b/Cabal/Distribution/Simple/PreProcess.hs
index e9dc66bdf567f6af460b0d588d2b22d497e83436..817a2452a607a65d230d49156f299ca8a2175d21 100644
--- a/Cabal/Distribution/Simple/PreProcess.hs
+++ b/Cabal/Distribution/Simple/PreProcess.hs
@@ -31,7 +31,6 @@ module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras,
import Prelude ()
import Distribution.Compat.Prelude
-import Distribution.Compat.Stack
import Distribution.Simple.PreProcess.Unlit
import Distribution.Backpack.DescribeUnitId
@@ -339,8 +338,10 @@ ppUnlit =
PreProcessor {
platformIndependent = True,
runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
- withUTF8FileContents inFile $ \contents ->
- either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents)
+ withUTF8FileContents inFile $ \contents -> do
+ case unlit inFile contents of
+ Right r -> writeUTF8File outFile r
+ Left err -> die' verbosity err
}
ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
@@ -740,7 +741,7 @@ preprocessExtras verbosity comp lbi = case comp of
pp :: FilePath -> IO [FilePath]
pp dir = (map (dir </>) . filter not_sub . concat)
<$> for knownExtrasHandlers
- (withLexicalCallStack (\f -> f dir) . unWrapPPE)
+ (\handler -> unWrapPPE handler dir)
-- TODO: This is a terrible hack to work around #3545 while we don't
-- reorganize the directory layout. Basically, for the main
-- library, we might accidentally pick up autogenerated sources for
diff --git a/Cabal/Distribution/Simple/Program/Ar.hs b/Cabal/Distribution/Simple/Program/Ar.hs
index 12fc610e387f731281d90c7b822b87efafa17eb5..d17064274f3f254357309ed4de2483a5e20c9ea1 100644
--- a/Cabal/Distribution/Simple/Program/Ar.hs
+++ b/Cabal/Distribution/Simple/Program/Ar.hs
@@ -133,7 +133,8 @@ wipeMetadata verbosity path = do
-- Check for existence first (ReadWriteMode would create one otherwise)
exists <- doesFileExist path
unless exists $ wipeError "Temporary file disappeared"
- withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h
+ withBinaryFile path ReadWriteMode $ \ h -> do size <- hFileSize h
+ wipeArchive h size
where
wipeError msg = dieWithLocation' verbosity path Nothing $
diff --git a/Cabal/Distribution/Simple/Program/Db.hs b/Cabal/Distribution/Simple/Program/Db.hs
index ec56ad803a51cd7a8b887c3492e25476002bcfaa..3911d4968613f6c15a098c143abfb562eb1bffe5 100644
--- a/Cabal/Distribution/Simple/Program/Db.hs
+++ b/Cabal/Distribution/Simple/Program/Db.hs
@@ -372,7 +372,7 @@ configurePrograms :: Verbosity
-> ProgramDb
-> IO ProgramDb
configurePrograms verbosity progs progdb =
- foldM (flip (configureProgram verbosity)) progdb progs
+ foldM (\db pgm -> configureProgram verbosity pgm db) progdb progs
-- | Unconfigure a program. This is basically a hack and you shouldn't
@@ -406,8 +406,8 @@ reconfigurePrograms :: Verbosity
-> IO ProgramDb
reconfigurePrograms verbosity paths argss progdb = do
configurePrograms verbosity progs
- . userSpecifyPaths paths
- . userSpecifyArgss argss
+ $ userSpecifyPaths paths
+ $ userSpecifyArgss argss
$ progdb
where
@@ -501,6 +501,8 @@ lookupProgramVersion verbosity prog range programDb = do
requireProgramVersion :: Verbosity -> Program -> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
-requireProgramVersion verbosity prog range programDb =
- join $ either (die' verbosity) return `fmap`
- lookupProgramVersion verbosity prog range programDb
+requireProgramVersion verbosity prog range programDb = do
+ result <- lookupProgramVersion verbosity prog range programDb
+ case result of
+ Left err -> die' verbosity err
+ Right res -> return res
diff --git a/Cabal/Distribution/Simple/Register.hs b/Cabal/Distribution/Simple/Register.hs
index 2c0bf61ac9e8021077a36f9f706c8a8f23be7fc1..a763ec385ea4d719ad91d2f30b75729a869d43c9 100644
--- a/Cabal/Distribution/Simple/Register.hs
+++ b/Cabal/Distribution/Simple/Register.hs
@@ -573,6 +573,7 @@ unregister pkg lbi regFlags = do
verbosity = fromFlag (regVerbosity regFlags)
packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))
(regPackageDB regFlags)
+ unreg :: HcPkg.HcPkgInfo -> IO ()
unreg hpi =
let invocation = HcPkg.unregisterInvocation
hpi Verbosity.normal packageDb pkgid
diff --git a/Cabal/Distribution/Simple/SrcDist.hs b/Cabal/Distribution/Simple/SrcDist.hs
index 6bc637df670a6dd2ecf23a156c4f7e62556a0e2b..e7069a60958c281082c009e183b694f0064753be 100644
--- a/Cabal/Distribution/Simple/SrcDist.hs
+++ b/Cabal/Distribution/Simple/SrcDist.hs
@@ -179,7 +179,7 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
, fmap concat
. withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do
biSrcs <- allSourcesBuildInfo verbosity flibBi pps []
- defFiles <- mapM (findModDefFile verbosity flibBi pps)
+ defFiles <- mapM (\file -> findModDefFile verbosity flibBi pps file)
(foreignLibModDefFile flib)
return (defFiles ++ biSrcs)
@@ -233,7 +233,7 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
let lbi = libBuildInfo l
incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi)
relincdirs = "." : filter isRelative (includeDirs lbi)
- traverse (fmap snd . findIncludeFile verbosity relincdirs) incls
+ traverse (\incl -> snd <$> findIncludeFile verbosity relincdirs incl) incls
-- Setup script, if it exists.
, fmap (maybe [] (\f -> [f])) $ findSetupFile ""
@@ -372,9 +372,11 @@ overwriteSnapshotPackageDesc verbosity pkg targetDir = do
-- We could just writePackageDescription targetDescFile pkg_descr,
-- but that would lose comments and formatting.
descFile <- defaultPackageDesc verbosity
- withUTF8FileContents descFile $
+ withUTF8FileContents descFile $ \contents ->
writeUTF8File (targetDir </> descFile)
- . unlines . map (replaceVersion (packageVersion pkg)) . lines
+ $ unlines
+ $ map (replaceVersion (packageVersion pkg))
+ $ lines contents
where
replaceVersion :: Version -> String -> String
diff --git a/Cabal/Distribution/Simple/Test.hs b/Cabal/Distribution/Simple/Test.hs
index 5547c7379887773930ce821b5780d51f99087769..ad9a4dda736c88f33123a1fe3e20630bd7be4587 100644
--- a/Cabal/Distribution/Simple/Test.hs
+++ b/Cabal/Distribution/Simple/Test.hs
@@ -42,6 +42,7 @@ import System.Directory
, removeFile )
import System.Exit ( exitFailure, exitSuccess )
import System.FilePath ( (</>) )
+import qualified Prelude (IO)
-- |Perform the \"@.\/setup test@\" action.
test :: Args -- ^positional command-line arguments
@@ -59,7 +60,7 @@ test args pkg_descr lbi flags = do
enabledTests = LBI.enabledTestLBIs pkg_descr lbi
doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo),
- Maybe TestSuiteLog) -> IO TestSuiteLog
+ Maybe TestSuiteLog) -> Prelude.IO TestSuiteLog
doTest ((suite, clbi), _) =
case PD.testInterface suite of
PD.TestSuiteExeV10 _ _ ->
diff --git a/Cabal/Distribution/Simple/Test/LibV09.hs b/Cabal/Distribution/Simple/Test/LibV09.hs
index 35dc367c85ed4104bb8305ef7bed1a2ac2082970..e0f0d882e5040fcb3a7f4bcf1375c6319c5a7e77 100644
--- a/Cabal/Distribution/Simple/Test/LibV09.hs
+++ b/Cabal/Distribution/Simple/Test/LibV09.hs
@@ -229,7 +229,8 @@ stubMain :: IO [Test] -> IO ()
stubMain tests = do
(f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse
dir <- getCurrentDirectory
- results <- (tests >>= stubRunTests) `CE.catch` errHandler
+ results <- CE.handle errHandler $ do tests'<- tests
+ stubRunTests tests'
setCurrentDirectory dir
stubWriteLog f n results
where
diff --git a/Cabal/Distribution/Simple/UserHooks.hs b/Cabal/Distribution/Simple/UserHooks.hs
index 306092186d1e7fcc9bcd94fc0906773c71f41303..e357dda2490adc7c1058264151257f52e7324f5c 100644
--- a/Cabal/Distribution/Simple/UserHooks.hs
+++ b/Cabal/Distribution/Simple/UserHooks.hs
@@ -32,7 +32,7 @@ module Distribution.Simple.UserHooks (
) where
import Prelude ()
-import Distribution.Compat.Prelude
+import Distribution.Compat.Prelude hiding (IO)
import Distribution.PackageDescription
import Distribution.Simple.Program
@@ -40,6 +40,8 @@ import Distribution.Simple.Command
import Distribution.Simple.PreProcess
import Distribution.Simple.Setup
import Distribution.Simple.LocalBuildInfo
+-- Use Prelude.IO to avoid impredicativity due to HasCallStack
+import Prelude (IO)
type Args = [String]
diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
index ccc35f5a99763a168a8e863b0497b15f52708e74..16198a854fc4808c105dbc10579958d799aa06ae 100644
--- a/Cabal/Distribution/Simple/Utils.hs
+++ b/Cabal/Distribution/Simple/Utils.hs
@@ -241,6 +241,7 @@ import qualified System.Process as Process
import qualified GHC.IO.Exception as GHC
import qualified Text.PrettyPrint as Disp
+import qualified Prelude (IO)
-- We only get our own version number when we're building with ourselves
cabalVersion :: Version
@@ -426,7 +427,7 @@ displaySomeException se =
#endif
topHandler :: IO a -> IO a
-topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog
+topHandler prog = topHandlerWith (\_ -> exitWith (ExitFailure 1)) prog
-- | Non fatal conditions that may be indicative of an error or problem.
--
@@ -915,7 +916,7 @@ xargs :: Int -> ([String] -> IO ())
xargs maxSize rawSystemFun fixedArgs bigArgs =
let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
chunkSize = maxSize - fixedArgSize
- in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
+ in traverse_ (\args -> rawSystemFun $ fixedArgs ++ args) (chunks chunkSize bigArgs)
where chunks len = unfoldr $ \s ->
if null s then Nothing
@@ -1019,7 +1020,7 @@ findModuleFilesEx :: Verbosity
-> [ModuleName] -- ^ modules
-> IO [(FilePath, FilePath)]
findModuleFilesEx verbosity searchPath extensions moduleNames =
- traverse (findModuleFileEx verbosity searchPath extensions) moduleNames
+ traverse (\modName -> findModuleFileEx verbosity searchPath extensions modName) moduleNames
{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}
findModuleFile :: [FilePath] -- ^ build prefix (location of objects)
@@ -1147,11 +1148,11 @@ createDirectoryIfMissingVerbose verbosity create_parents path0
parents = reverse . scanl1 (</>) . splitDirectories . normalise
createDirs [] = return ()
- createDirs (dir:[]) = createDir dir throwIO
+ createDirs (dir:[]) = createDir dir (\exc -> throwIO exc)
createDirs (dir:dirs) =
createDir dir $ \_ -> do
createDirs dirs
- createDir dir throwIO
+ createDir dir (\exc -> throwIO exc)
createDir :: FilePath -> (IOException -> IO ()) -> IO ()
createDir dir notExistHandler = do
@@ -1170,7 +1171,7 @@ createDirectoryIfMissingVerbose verbosity create_parents path0
| isAlreadyExistsError e -> (do
isDir <- doesDirectoryExist dir
unless isDir $ throwIO e
- ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())
+ ) `catchIO` ((\_ -> return ()) :: IOException -> Prelude.IO ())
| otherwise -> throwIO e
createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
@@ -1231,7 +1232,7 @@ copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
- traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs
+ traverse_ (\dir -> createDirectoryIfMissingVerbose verbosity True dir) dirs
-- Copy all the files
sequence_ [ let src = srcBase </> srcFile
@@ -1295,8 +1296,8 @@ copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do
info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
srcFiles <- getDirectoryContentsRecursive srcDir
- copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f)
- | f <- srcFiles ]
+ copyFilesWith (\_ f g -> copyFile f g) verbosity destDir [ (srcDir, f)
+ | f <- srcFiles ]
-------------------
-- File permissions
@@ -1355,8 +1356,7 @@ withTempFileEx opts tmpDir template action =
--
withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectory verbosity targetDir template f = withFrozenCallStack $
- withTempDirectoryEx verbosity defaultTempFileOptions targetDir template
- (withLexicalCallStack f)
+ withTempDirectoryEx verbosity defaultTempFileOptions targetDir template f
-- | A version of 'withTempDirectory' that additionally takes a
-- 'TempFileOptions' argument.
@@ -1481,8 +1481,11 @@ findPackageDesc dir
-- |Like 'findPackageDesc', but calls 'die' in case of error.
tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath
-tryFindPackageDesc verbosity dir =
- either (die' verbosity) return =<< findPackageDesc dir
+tryFindPackageDesc verbosity dir = do
+ desc <- findPackageDesc dir
+ case desc of
+ Left err -> die' verbosity err
+ Right d -> return d
-- |Find auxiliary package information in the given directory.
-- Looks for @.buildinfo@ files.
diff --git a/Cabal/Distribution/Utils/Generic.hs b/Cabal/Distribution/Utils/Generic.hs
index e0e72cec51fb3cf78c981e487a4fa0b211edb8ce..852923f0ba63687069704e75288c02cd1d8269bb 100644
--- a/Cabal/Distribution/Utils/Generic.hs
+++ b/Cabal/Distribution/Utils/Generic.hs
@@ -256,8 +256,9 @@ readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> BS.readFile f
--
withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
withUTF8FileContents name action =
- withBinaryFile name ReadMode
- (\hnd -> BS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)
+ withBinaryFile name ReadMode $ \hnd -> do
+ contents <- BS.hGetContents hnd
+ action $ ignoreBOM $ fromUTF8LBS contents
-- | Writes a Unicode String as a UTF8 encoded text file.
--