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. --