WIP: Adapt to simplifed subsumption proposal

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

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

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 ++ "\"."

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"]

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)

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

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

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)

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

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)

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