[fix] Changed to use the Parallel effect in the form of 'liftA2' instead of '<*>', as it might be slightly faster (?)

heftia-effects/bench/BenchParallel.hs

@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+
+-- SPDX-License-Identifier: MPL-2.0
+
+module BenchParallel where
+
+import Control.Monad (liftM2)
+import Control.Monad.Hefty (Eff, type (<:), type (<|))
+import Control.Monad.Hefty.Concurrent.Parallel (runParallelIO)
+import Control.Monad.Hefty.Concurrent.Stream (closing, connect)
+import Control.Monad.Hefty.Input (Input, input)
+import Control.Monad.Hefty.Output (Output, output)
+import Control.Monad.Hefty.Unlift (runUnliftIO)
+import Control.Monad.IO.Class (MonadIO)
+import Data.Foldable (for_)
+import Data.Maybe (fromJust)
+import Data.These.Combinators (justThese)
+import System.IO.Unsafe (unsafePerformIO)
+
+produce :: (Output Int <| ef) => Int -> Eff '[] ef ()
+produce n =
+    for_ [1 .. n] \(i :: Int) -> do
+        output i
+
+consume :: (Input Int <: m, MonadIO m) => Int -> m [Int]
+consume 0 = pure []
+consume n = liftM2 (:) (input @Int) (consume (n - 1))
+
+parallel :: Int -> [Int]
+parallel n = unsafePerformIO . runUnliftIO . runParallelIO $ do
+    stat <- connect @Int (produce n) (consume n)
+    pure $ snd . fromJust $ justThese $ closing stat
+{-# NOINLINE parallel #-}

heftia-effects/bench/Main.hs

@@ -6,6 +6,7 @@ module Main where
 import BenchCatch
 import BenchCoroutine
 import BenchCountdown
+import BenchParallel
 import BenchPyth
 import Data.Functor ((<&>))
 import Test.Tasty.Bench
@@ -111,4 +112,9 @@ main =
                     , bench "eff.5+5" $ nf coroutineEffDeep x
                     , bench "mp.5+5" $ nf coroutineMpDeep x
                     ]
+        , bgroup "parallel" $
+            [10000] <&> \x ->
+                bgroup
+                    (show x)
+                    [bench "parallel" $ nf parallel x]
         ]

heftia-effects/heftia-effects.cabal

@@ -270,3 +270,4 @@ benchmark heftia-bench
         -- BenchLocal
         BenchCoroutine
         BenchPyth
+        BenchParallel

heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs

@@ -31,9 +31,7 @@ import UnliftIO qualified as IO
 import UnliftIO.Concurrent (threadDelay)
 
 data Parallel f a where
-    Parallel :: f (a -> b) -> f a -> Parallel f b
-
--- LiftP2 :: (a -> b -> c) -> f a -> f b -> Parallel f c
+    LiftP2 :: (a -> b -> c) -> f a -> f b -> Parallel f c
 
 data Halt (a :: Type) where
     Halt :: Halt a
@@ -50,11 +48,8 @@ instance (Parallel <<: f, Applicative f) => Applicative (Concurrently f) where
     pure = Concurrently . pure
     {-# INLINE pure #-}
 
-    Concurrently f <*> Concurrently m = Concurrently $ parallel f m
-    {-# INLINE (<*>) #-}
-
--- liftA2 f (Concurrently a) (Concurrently b) = Concurrently $ liftP2 f a b
--- {-# INLINE liftA2 #-}
+    liftA2 f (Concurrently a) (Concurrently b) = Concurrently $ liftP2 f a b
+    {-# INLINE liftA2 #-}
 
 instance (Race <<: f, Halt <: f, Parallel <<: f, Applicative f) => Alternative (Concurrently f) where
     empty = Concurrently halt
@@ -63,10 +58,6 @@ instance (Race <<: f, Halt <: f, Parallel <<: f, Applicative f) => Alternative (
     (Concurrently a) <|> (Concurrently b) = Concurrently $ race a b
     {-# INLINE (<|>) #-}
 
-liftP2 :: (Parallel <<: f, Applicative f) => (a -> b -> c) -> f a -> f b -> f c
-liftP2 f a b = runConcurrently $ liftA2 f (Concurrently a) (Concurrently b)
-{-# INLINE liftP2 #-}
-
 liftP3 :: (Parallel <<: f, Applicative f) => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
 liftP3 f a b c = runConcurrently $ liftA3 f (Concurrently a) (Concurrently b) (Concurrently c)
 {-# INLINE liftP3 #-}
@@ -84,7 +75,7 @@ runHaltIO :: (IO <| ef) => Eff eh (Halt ': ef) ~> Eff eh ef
 runHaltIO = interpret haltToIO
 
 parallelToIO :: (MonadUnliftIO m) => Parallel ~~> m
-parallelToIO (Parallel f m) = IO.runConcurrently $ IO.Concurrently f <*> IO.Concurrently m
+parallelToIO (LiftP2 f a b) = IO.runConcurrently $ liftA2 f (IO.Concurrently a) (IO.Concurrently b)
 {-# INLINE parallelToIO #-}
 
 raceToIO :: (MonadUnliftIO m) => Race ~~> m