diff --git a/cabal.project b/cabal.project index 43d6785..9f96719 100644 --- a/cabal.project +++ b/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 diff --git a/heftia-effects/heftia-effects.cabal b/heftia-effects/heftia-effects.cabal index 6fc3971..2b83349 100644 --- a/heftia-effects/heftia-effects.cabal +++ b/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: diff --git a/heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs b/heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs index e5cf5c9..25e89a9 100644 --- a/heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs +++ b/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 diff --git a/heftia/src/Control/Monad/Hefty.hs b/heftia/src/Control/Monad/Hefty.hs index d7d8fe8..bebee37 100644 --- a/heftia/src/Control/Monad/Hefty.hs +++ b/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