diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs
index 999e1bf4e6928d67a73a539be4d7c33d9c3f8f5a..2ebb7dba549b7f5dc93dde350aaf939e7bcfdd6a 100644
--- a/compiler/GHC/Cmm/Pipeline.hs
+++ b/compiler/GHC/Cmm/Pipeline.hs
@@ -26,11 +26,11 @@ import GHC.Types.Unique.Supply
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Outputable
+import GHC.Utils.Misc ( partitionWithM )
import GHC.Platform
import Control.Monad
-import Data.Either (partitionEithers)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
@@ -50,9 +50,7 @@ cmmPipeline logger cmm_config srtInfo prog = do
let forceRes (info, group) = info `seq` foldr seq () group
let platform = cmmPlatform cmm_config
withTimingSilent logger (text "Cmm pipeline") forceRes $ do
- tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog
-
- let (procs, data_) = partitionEithers tops
+ (procs, data_) <- {-# SCC "tops" #-} partitionWithM (cpsTop logger platform cmm_config) prog
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_
dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 348bc60f3c10039054f89c7a69833ef1b5c68193..bac99883e2c5ea792560ff0c543fc3a8ece8f319 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -1569,9 +1569,8 @@ downsweep :: HscEnv
-- which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots
= do
- rootSummaries <- mapM getRootSummary roots
- let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549
- root_map = mkRootMap rootSummariesOk
+ (root_errs, rootSummariesOk) <- partitionWithM getRootSummary roots -- #17549
+ let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
(deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)
let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 2cfddd72b7ef84f35998b3152056a5bef64d1e2c..5f6a71ec8f56734f69ca4aee03a058392ce2b8e1 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -124,7 +124,6 @@ import System.IO
import Control.Monad
import qualified Control.Monad.Catch as MC (handle)
import Data.Maybe
-import Data.Either ( partitionEithers )
import qualified Data.Set as Set
import Data.Time ( getCurrentTime )
@@ -489,8 +488,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
Right t -> do
-- first check object files and extra_ld_inputs
let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
- e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
- let (errs,extra_times) = partitionEithers e_extra_times
+ (errs,extra_times) <- partitionWithM (tryIO . getModificationUTCTime) extra_ld_inputs
let obj_times = map linkableTime linkables ++ extra_times
if not (null errs) || any (t <) obj_times
then return $ needsRecompileBecause ObjectsChanged
@@ -514,9 +512,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do
- e_lib_times <- mapM (tryIO . getModificationUTCTime)
- (catMaybes pkg_libfiles)
- let (lib_errs,lib_times) = partitionEithers e_lib_times
+ (lib_errs,lib_times) <- partitionWithM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles)
if not (null lib_errs) || any (t <) lib_times
then return $ needsRecompileBecause LibraryChanged
else do
diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs
index 4fdfa0a7ed026eadc9efafe8713c65d040817052..0b6b162d2c29fc86113f09db54b07bf135787c19 100644
--- a/compiler/GHC/StgToJS/Deps.hs
+++ b/compiler/GHC/StgToJS/Deps.hs
@@ -48,7 +48,6 @@ import qualified Data.IntSet as IS
import qualified GHC.Data.Word64Map as WM
import GHC.Data.Word64Map (Word64Map)
import Data.Array
-import Data.Either
import Data.Word
import Control.Monad
@@ -101,9 +100,9 @@ genDependencyData mod units = do
-> Int
-> StateT DependencyDataCache G (Int, BlockDeps, Bool, [ExportedFun])
oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do
- (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps
- (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps
- (edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps
+ (edi, bdi) <- partitionWithM (lookupIdFun n) idDeps
+ (edo, bdo) <- partitionWithM lookupOtherFun otherDeps
+ (edp, bdp) <- partitionWithM (lookupPseudoIdFun n) pseudoIdDeps
expi <- mapM lookupExportedId (filter isExportedId idExports)
expo <- mapM lookupExportedOther otherExports
-- fixme thin deps, remove all transitive dependencies!
diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs
index cb0f6ddb286cbe65c07407f295119aad663c7406..3dd39ea5902b67f68fbc8c4355b0650aca0d82d3 100644
--- a/compiler/GHC/StgToJS/Expr.hs
+++ b/compiler/GHC/StgToJS/Expr.hs
@@ -80,7 +80,6 @@ import qualified GHC.Data.List.SetOps as ListSetOps
import Data.Monoid
import Data.Maybe
import Data.Function
-import Data.Either
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Map as M
@@ -509,7 +508,7 @@ optimizeFree offset ids = do
-- | Allocate local closures
allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat
allocCls dynMiddle xs = do
- (stat, dyn) <- partitionEithers <$> mapM toCl xs
+ (stat, dyn) <- partitionWithM toCl xs
ac <- allocDynAll False dynMiddle dyn
pure (mconcat stat <> ac)
where
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index f07137cbb48382c828b7291ba6af90fa260da541..357bf82bfcd9fcb71aec4c6986982ed34be3f2f1 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -23,7 +23,7 @@ module GHC.Utils.Misc (
mapFst, mapSnd, chkAppend,
mapAndUnzip, mapAndUnzip3, mapAndUnzip4,
- filterOut, partitionWith,
+ filterOut, partitionWith, partitionWithM,
dropWhileEndLE, spanEnd, last2, lastMaybe, onJust,
@@ -219,6 +219,16 @@ partitionWith f (x:xs) = case f x of
Right c -> (bs, c:cs)
where (bs,cs) = partitionWith f xs
+partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])
+-- ^ Monadic version of `partitionWith`
+partitionWithM _ [] = return ([], [])
+partitionWithM f (x:xs) = do
+ y <- f x
+ (bs, cs) <- partitionWithM f xs
+ case y of
+ Left b -> return (b:bs, cs)
+ Right c -> return (bs, c:cs)
+
chkAppend :: [a] -> [a] -> [a]
-- Checks for the second argument being empty
-- Used in situations where that situation is common