Parallel traverse with V and Compose

Main.purs

module Main where

import Prelude

import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except as Except
import Control.Monad.Except as ExceptT
import Control.Parallel as Parallel
import Control.Parallel (class Parallel)
import Data.Array ((..))
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NonEmpty
import Data.Bifunctor as Bifunctor
import Data.Functor.Compose (Compose(..))
import Data.Newtype as Newtype
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (class Traversable)
import Data.Traversable as Traversable
import Data.Validation.Semigroup (V(..))
import Data.Validation.Semigroup as V
import Effect (Effect)
import Effect.Aff (Aff, ParAff)
import Effect.Aff as Aff
import Effect.Aff.Class (class MonadAff)
import Effect.Aff.Class as Aff.Class
import Effect.Class.Console as Console

delaySeconds :: forall m. MonadAff m => Number -> m Unit
delaySeconds n = Aff.Class.liftAff do
  Aff.delay (Milliseconds (n * 1000.0))

delayedThrow :: Int -> ExceptT Int Aff Unit
delayedThrow err = do
  delaySeconds 1.0
  Console.logShow err
  Except.throwError err

-- traverseV
--   :: forall t a b err
--   . Traversable t
--   => (a -> ExceptT err Aff b)
--   -> t a
--   -> ExceptT (NonEmptyArray err) Aff (t b)
traverseV
  :: forall f m t a b err
   . Traversable t
  => Parallel f m
  => (a -> ExceptT err m b)
  -> t a
  -> ExceptT (NonEmptyArray err) m (t b)
traverseV f = ExceptT
  <<< Parallel.sequential
  <<< map V.toEither
  <<< Newtype.unwrap
  <<< Traversable.traverse (toComposeV <<< f)

  where
  toComposeV :: ExceptT err m b -> Compose f (V (NonEmptyArray err)) b
  toComposeV =
    Compose
      <<< Parallel.parallel
      <<< map (V <<< Bifunctor.lmap (NonEmpty.singleton))
      <<< ExceptT.runExceptT

main :: Effect Unit
main = do
  let xs = 1 .. 10

  Console.time "parTraverse"
  Aff.runAff_ (\result -> Console.timeEnd "parTraverse" *> Console.logShow result) do
    ExceptT.runExceptT (Parallel.parTraverse delayedThrow xs)

  Console.time "traverseV"
  Aff.runAff_ (\result -> Console.timeEnd "traverseV" *> Console.logShow result) do
    ExceptT.runExceptT (traverseV delayedThrow xs)