Move the definition of parallelism effects to data-effects.

cabal.project

@@ -10,5 +10,13 @@ source-repository-package
 
 allow-newer: eff:primitive
 
+source-repository-package
+    type: git
+    location: https://github.com/sayo-hs/data-effects
+    tag: 9fd125aecb96c7d56db7c464abd31056bc17c921
+    subdir: data-effects-core
+    subdir: data-effects-th
+    subdir: data-effects
+
 benchmarks: True
 tests: True

heftia-effects/heftia-effects.cabal

@@ -120,7 +120,9 @@ library
         Data.Effect.KVStore,
         Data.Effect.Fresh,
         Data.Effect.Fail,
+        Data.Effect.Concurrent.Parallel,
         Data.Effect.Concurrent.Timer,
+        Data.Effect.Log,
 
     -- Modules included in this executable, other than Main.
     -- other-modules:

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

@@ -1,67 +1,30 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 
 -- SPDX-License-Identifier: MPL-2.0
 
-module Control.Monad.Hefty.Concurrent.Parallel where
+module Control.Monad.Hefty.Concurrent.Parallel (
+    module Control.Monad.Hefty.Concurrent.Parallel,
+    module Data.Effect.Concurrent.Parallel,
+)
+where
 
-import Control.Applicative (Alternative, empty, liftA3, (<|>))
+import Control.Applicative ((<|>))
 import Control.Monad (forever)
 import Control.Monad.Hefty (
     Eff,
-    Type,
     interpret,
     interpretH,
-    makeEffect,
-    makeEffectH_,
-    type (<:),
-    type (<<:),
     type (<<|),
     type (<|),
     type (~>),
     type (~~>),
  )
 import Control.Monad.Hefty.Unlift (UnliftIO)
-import Data.Effect.HFunctor.TH (makeHFunctor')
-import Data.List.Infinite (Infinite ((:<)))
+import Data.Effect.Concurrent.Parallel
 import UnliftIO (MonadIO, MonadUnliftIO, liftIO)
 import UnliftIO qualified as IO
 import UnliftIO.Concurrent (threadDelay)
 
-data Parallel f a where
-    LiftP2 :: (a -> b -> c) -> f a -> f b -> Parallel f c
-
-data Halt (a :: Type) where
-    Halt :: Halt a
-
-data Race f (a :: Type) where
-    Race :: f a -> f a -> Race f a
-
-makeEffect [''Halt] [''Parallel, ''Race]
-
-newtype Concurrently f a = Concurrently {runConcurrently :: f a}
-    deriving (Functor)
-
-instance (Parallel <<: f, Applicative f) => Applicative (Concurrently f) where
-    pure = Concurrently . pure
-    {-# INLINE pure #-}
-
-    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
-    {-# INLINE empty #-}
-
-    (Concurrently a) <|> (Concurrently b) = Concurrently $ race a b
-    {-# INLINE (<|>) #-}
-
-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 #-}
-
 runConcurrentIO :: (UnliftIO <<| eh, IO <| ef) => Eff (Race ': Parallel ': eh) (Halt ': ef) ~> Eff eh ef
 runConcurrentIO = runHaltIO . runParallelIO . runRaceIO
 
@@ -86,10 +49,5 @@ haltToIO :: (MonadIO m) => Halt ~> m
 haltToIO Halt = liftIO $ forever $ threadDelay maxBound
 {-# INLINE haltToIO #-}
 
-data For (t :: Type -> Type) f a where
-    For :: t (f a) -> For t f (t a)
-makeEffectH_ [''For]
-makeHFunctor' ''For \(t :< _) -> [t|Functor $t|]
-
-forToParallel :: (Parallel <<| eh, Traversable t) => For t ~~> Eff eh ef
-forToParallel (For iters) = runConcurrently $ traverse Concurrently iters
+runForAsParallel :: (Parallel <<| eh, Traversable t) => Eff (For t ': eh) ef ~> Eff eh ef
+runForAsParallel = interpretH forToParallel

heftia/src/Control/Monad/Hefty.hs

@@ -648,6 +648,8 @@ module Control.Monad.Hefty (
     module Data.Effect.OpenUnion,
     module Data.Effect,
     module Data.Effect.TH,
+    module Data.Effect.HFunctor.TH,
+    module Data.Effect.Key.TH,
     module Control.Effect,
 ) where
 
@@ -791,6 +793,8 @@ import Control.Monad.Hefty.Types (
 import Control.Monad.IO.Class (liftIO)
 import Data.Effect
 import Data.Effect.HFunctor (HFunctor)
+import Data.Effect.HFunctor.TH
+import Data.Effect.Key.TH
 import Data.Effect.OpenUnion
 import Data.Effect.OpenUnion.Sum (type (:+:))
 import Data.Effect.TH