foldCommuteIO.hs

tryAll :: IO a -> IO (Either SomeException a)
tryAll = try

forkIO_ :: IO () -> IO ()
forkIO_ x = forkIO x >> pure ()

foldCommuteIO :: forall t m a. (Foldable t, Monoid m) => (a -> IO m) -> t a -> IO m
foldCommuteIO f xs = do
  var <- newEmptyMVar
  total <- foldlM (\ !n a -> forkIO_ ( tryAll (f a) >>= putMVar var) >> pure (n + 1)) 0 xs
  let go2 :: Int -> SomeException -> IO (Either SomeException m)
      go2 !n e = if (n :: Int) < total
        then takeMVar var *> go2 (n + 1) e
        else pure $ Left e
  let go :: Int -> m -> IO (Either SomeException m)
      go !n !m = if (n :: Int) < total
        then takeMVar var >>= \case
          Left r -> go2 (n + 1) r
          Right m' -> go (n + 1) (m <> m')
        else pure $ Right m
  x <- go 0 mempty
  case x of
    Left e -> error $ "Exception encountered in thread. Terminating." <> show e
    Right m -> pure m