diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,26 +1,33 @@ {-# LANGUAGE FlexibleContexts, TypeApplications #-} - +{-# OPTIONS_GHC -ddump-simpl #-} import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Control.Effects.State - +import qualified Control.Effects.State as Eff1 import Control.Monad.State.Strict import Control.Monad.Trans.State.Strict (execStateT) import Criterion.Main +modify'' :: MonadState s m => (s -> s) -> m () +modify'' f = do + s <- get + let s' = f s + s' `seq` put s' +{-# INLINE modify'' #-} + mtlSimple :: MonadState Int m => m () mtlSimple = replicateM_ 1000000 mtlSimple' - where mtlSimple' = modify' (+ 1) + where mtlSimple' = modify'' (+ 1) -effectsSimple :: (MonadEffectState Int m) => m () +effectsSimple :: (Eff1.MonadEffect (Eff1.State Int) m) => m () effectsSimple = replicateM_ 1000000 effectsSimple' - where effectsSimple' = modifyState (+ (1 :: Int)) + where effectsSimple' = Eff1.modifyState (+ (1 :: Int)) main :: IO () main = do setLocaleEncoding utf8 defaultMain [ bench "MTL state" $ nfIO (execStateT mtlSimple 0) - , bench "Effects state" $ nfIO effState + , bench "Effects state" $ nfIO effState1 ] - where effState = handleStateT (0 :: Int) (effectsSimple >> getState @Int) + where + effState1 = Eff1.handleStateT (0 :: Int) (effectsSimple >> Eff1.getState @Int) diff --git a/simple-effects.cabal b/simple-effects.cabal --- a/simple-effects.cabal +++ b/simple-effects.cabal @@ -1,63 +1,66 @@ -name: simple-effects -version: 0.9.0.1 -cabal-version: >=1.10 -build-type: Simple -license: BSD3 -license-file: LICENSE -copyright: 2016 Luka Horvat -maintainer: luka.horvat9@gmail.com -homepage: https://gitlab.com/LukaHorvat/simple-effects -synopsis: A simple effect system that integrates with MTL -description: - Please see README.md -category: Control -author: Luka Horvat - -library - exposed-modules: - Control.Effects - Control.Effects.State - Control.Effects.Reader - Control.Effects.List - Control.Effects.Signal - Control.Effects.Early - Control.Effects.Parallel - Control.Monad.Runnable - build-depends: - base >=4.7 && <5, - transformers >=0.5.2.0, - mtl >=2.2.1, - monad-control ==1.0.*, - transformers-base ==0.4.*, - list-t >=1, - array >=0.5.1.1, - MonadRandom >=0.5.1, - exceptions >=0.8.3, - text >=1.2.2.1 - default-language: Haskell2010 - hs-source-dirs: src - other-modules: - Import - ghc-options: -Wall - -test-suite tests - type: exitcode-stdio-1.0 - main-is: Main.hs - build-depends: - base >=4.7 && <5, - simple-effects >=0.9.0.1 - default-language: Haskell2010 - hs-source-dirs: test - ghc-options: -Wall -threaded -with-rtsopts=-N - -benchmark bench-effects - type: exitcode-stdio-1.0 - main-is: Bench.hs - build-depends: - base >=4.9.1.0, - criterion >=1.1.4.0, - mtl >=2.2.1, - transformers >=0.5.2.0, - simple-effects >=0.9.0.1 - default-language: Haskell2010 - hs-source-dirs: bench +name: simple-effects +version: 0.10.0.0 +synopsis: A simple effect system that integrates with MTL +description: Please see the tutorial modules +homepage: https://gitlab.com/LukaHorvat/simple-effects +license: BSD3 +license-file: LICENSE +author: Luka Horvat +maintainer: luka.horvat9@gmail.com +copyright: 2018 Luka Horvat +category: Control +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Control.Effects + , Control.Effects.State + , Control.Effects.Reader + , Control.Effects.List + , Control.Effects.Signal + , Control.Effects.Early + , Control.Effects.Parallel + , Control.Effects.Generic + , Control.Effects.Async + , Control.Monad.Runnable + , Tutorial.T1_Introduction + , Tutorial.T2_Details + , Tutorial.T3_CustomEffects + other-modules: Import + Tutorial.Test + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , transformers + , mtl + , monad-control == 1.0.* + , transformers-base == 0.4.* + , list-t + , array + , MonadRandom + , exceptions + , text + , bytestring + , async + ghc-options: -Wall -O2 + +test-suite tests + hs-source-dirs: test + main-is: Main.hs + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5 + , simple-effects + ghc-options: -Wall -threaded -with-rtsopts=-N + +benchmark bench-effects + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + build-depends: base + , criterion + , mtl + , transformers + , simple-effects + default-language: Haskell2010 + ghc-options: -O2 diff --git a/src/Control/Effects.hs b/src/Control/Effects.hs --- a/src/Control/Effects.hs +++ b/src/Control/Effects.hs @@ -1,65 +1,76 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor - , GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving - , IncoherentInstances #-} -{-# LANGUAGE DataKinds, PolyKinds, TypeInType, Rank2Types, TypeOperators, ConstraintKinds #-} +{-# LANGUAGE TypeFamilies, RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, InstanceSigs, UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving, DataKinds #-} +{-# LANGUAGE TypeOperators #-} module Control.Effects (module Control.Effects) where -import Import +import Import hiding (liftThrough) import Control.Monad.Runnable -import Data.Kind - -data MsgOrRes = Msg | Res -data family Effect (effKind :: Type) :: effKind -> MsgOrRes -> Type - -class Monad m => MonadEffect effKind m where - -- | Use the effect described by 'method'. - effect :: Effect effKind method 'Msg -> m (Effect effKind method 'Res) +import Control.Effects.Generic +import GHC.Generics -newtype EffectWithKind effKind m = EffectWithKind - { getEffectWithKind :: forall method. Effect effKind method 'Msg -> m (Effect effKind method 'Res) } +class Effect e where + data EffMethods e (m :: * -> *) :: * + type CanLift e (t :: (* -> *) -> * -> *) :: Constraint + type CanLift e t = MonadTrans t + liftThrough :: + forall t m. (CanLift e t, Monad m, Monad (t m)) + => EffMethods e m -> EffMethods e (t m) + default liftThrough :: + forall t m. + ( Generic (EffMethods e m), MonadTrans t, Monad m, Monad (t m) + , SimpleMethods (EffMethods e) m t ) + => EffMethods e m -> EffMethods e (t m) + liftThrough = genericLiftThrough + + mergeContext :: Monad m => m (EffMethods e m) -> EffMethods e m + default mergeContext :: + (Generic (EffMethods e m), MonadicMethods (EffMethods e) m) + => m (EffMethods e m) -> EffMethods e m + mergeContext = genericMergeContext --- | The 'EffectHandler' is really just a 'ReaderT' carrying around the function that knows how to --- handle the effect. -newtype EffectHandler effKind m a = EffectHandler - { unpackEffectHandler :: ReaderT (EffectWithKind effKind m) m a } - deriving ( Functor, Applicative, Monad, Alternative, MonadState s, MonadIO, MonadCatch - , MonadThrow, MonadRandom ) +class (Effect e, Monad m) => MonadEffect e m where + effect :: EffMethods e m -instance MonadTrans (EffectHandler effKind) where - lift = EffectHandler . lift +instance {-# OVERLAPPABLE #-} + (MonadEffect e m, Monad (t m), CanLift e t) + => MonadEffect e (t m) where + effect = liftThrough effect -instance RunnableTrans (EffectHandler effKind) where - type TransformerState (EffectHandler effKind) m = EffectWithKind effKind m - type TransformerResult (EffectHandler effKind) m a = a - currentTransState = EffectHandler ask - restoreTransState = return - runTransformer m = runReaderT (unpackEffectHandler m) +newtype RuntimeImplemented e m a = RuntimeImplemented + { getRuntimeImplemented :: ReaderT (EffMethods e m) m a } + deriving + (Functor, Applicative, Monad, MonadPlus, Alternative, MonadState s, MonadIO, MonadCatch + , MonadThrow, MonadRandom ) -instance MonadReader s m => MonadReader s (EffectHandler effKind m) where - ask = EffectHandler (lift ask) - local f (EffectHandler rdr) = EffectHandler (ReaderT $ local f . runReaderT rdr) +instance MonadTrans (RuntimeImplemented e) where + lift = RuntimeImplemented . lift -deriving instance MonadBase b m => MonadBase b (EffectHandler effKind m) +instance MonadReader r m => MonadReader r (RuntimeImplemented e m) where + ask = RuntimeImplemented (lift ask) + local f (RuntimeImplemented rdr) = RuntimeImplemented (ReaderT (local f . runReaderT rdr)) -instance MonadBaseControl b m => MonadBaseControl b (EffectHandler effKind m) where - type StM (EffectHandler effKind m) a = StM (ReaderT (EffectWithKind effKind m) m) a - liftBaseWith f = EffectHandler $ liftBaseWith $ \q -> f (q . unpackEffectHandler) - restoreM = EffectHandler . restoreM +deriving instance MonadBase b m => MonadBase b (RuntimeImplemented e m) +instance MonadBaseControl b m => MonadBaseControl b (RuntimeImplemented e m) where + type StM (RuntimeImplemented e m) a = StM (ReaderT (EffMethods e m) m) a + liftBaseWith f = RuntimeImplemented $ liftBaseWith $ \q -> f (q . getRuntimeImplemented) + restoreM = RuntimeImplemented . restoreM -instance {-# OVERLAPPABLE #-} (MonadEffect method m, MonadTrans t, Monad (t m)) - => MonadEffect method (t m) where - {-# INLINE effect #-} - effect msg = lift (effect msg) +instance RunnableTrans (RuntimeImplemented e) where + type TransformerResult (RuntimeImplemented e) m a = a + type TransformerState (RuntimeImplemented e) m = EffMethods e m + currentTransState = RuntimeImplemented ask + restoreTransState = return + runTransformer (RuntimeImplemented m) = runReaderT m -instance Monad m => MonadEffect effKind (EffectHandler effKind m) where - {-# INLINE effect #-} - effect msg = EffectHandler (ReaderT (($ msg) . getEffectWithKind)) +instance (Effect e, Monad m, CanLift e (RuntimeImplemented e)) + => MonadEffect e (RuntimeImplemented e m) where + effect = mergeContext $ RuntimeImplemented (liftThrough <$> ask) --- | Handle the effect described by 'effKind'. -handleEffect :: - (forall method. Effect effKind method 'Msg -> m (Effect effKind method 'Res)) - -> EffectHandler effKind m a -> m a -handleEffect f eh = runReaderT (unpackEffectHandler eh) (EffectWithKind f) +implement :: forall e m a. EffMethods e m -> RuntimeImplemented e m a -> m a +implement em (RuntimeImplemented r) = runReaderT r em type family MonadEffects effs m :: Constraint where MonadEffects '[] m = () diff --git a/src/Control/Effects/Async.hs b/src/Control/Effects/Async.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effects/Async.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-| The 'Async' effect allows you to fork new threads in monads other than just 'IO'. +-} +module Control.Effects.Async where + +import Import +import Control.Effects +import qualified Control.Concurrent.Async as Async +import Control.Monad.Runnable +import Control.Effects.State + +-- | The name of the effect +data Async + +-- | The type that represents the forked computation in the monad @m@ that eventually computes +-- a value of type @a@. Depending on the monad, the computation may produce zero, one or even +-- multiple values of that type. +newtype AsyncThread m a = AsyncThread (Async.Async (m a)) + deriving (Functor, Eq, Ord) + +instance Effect Async where + data EffMethods Async m = AsyncMethods + { _async :: forall a. m a -> m (AsyncThread m a) + , _waitAsync :: forall a. AsyncThread m a -> m a } + type CanLift Async t = RunnableTrans t + mergeContext mm = AsyncMethods + (\a -> mm >>= ($ a) . _async) + (\a -> mm >>= ($ a) . _waitAsync) + liftThrough (AsyncMethods f g) = AsyncMethods + (\tma -> do + st <- currentTransState + !res <- lift (f (runTransformer tma st)) + return $ mapAsync (lift >=> restoreTransState) res + ) + (\a -> do + st <- currentTransState + res <- lift (g (mapAsync (`runTransformer` st) a)) + restoreTransState res + ) + where + mapAsync :: (m a -> n b) -> AsyncThread m a -> AsyncThread n b + mapAsync f' (AsyncThread as) = AsyncThread (fmap f' as) + +-- | The 'IO' implementation uses the @async@ library. +instance MonadEffect Async IO where + effect = AsyncMethods + (fmap (AsyncThread . fmap return) . Async.async) + (\(AsyncThread as) -> join (Async.wait as)) + +-- | Fork a new thread to run the given computation. The monadic context is forked into the new +-- thread. +-- +-- For example, if we use state, the current state value will be visible int he forked computation. +-- Depending on how we ultimately implement the state, modifying it may or may not be visible +-- from the main thread. If we use 'implementStateViaStateT' then setting the state in the forked +-- thread will just modify the thread-local value. On the other hand, if we use +-- 'implementStateViaIORef' then both the main thread and the new thread will use the same reference +-- meaning they can interact through it. +async :: MonadEffect Async m => m a -> m (AsyncThread m a) + +-- | Wait for the thread to finish and return it's result. The monadic context will also be merged. +-- +-- Example: +-- +-- @ +-- 'setState' \@Int 1 +-- th <- 'async' $ do +-- 'setState' \@Int 2 +-- 'waitAsync' th +-- print =<< 'getState' \@Int -- Outputs 2 +-- @ +waitAsync :: MonadEffect Async m => AsyncThread m a -> m a +AsyncMethods async waitAsync = effect + +-- | This will discard the @'MonadEffect' 'Async' m@ constraint by forcing @m@ to be 'IO'. +-- The functions doesn't actually do anything, the real implementation is given by the +-- @'MonadEffect' 'Async' IO@ instance which uses the @async@ package. +implementAsyncViaIO :: IO a -> IO a +implementAsyncViaIO = id diff --git a/src/Control/Effects/Early.hs b/src/Control/Effects/Early.hs --- a/src/Control/Effects/Early.hs +++ b/src/Control/Effects/Early.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes, TypeFamilies, FlexibleContexts, ScopedTypeVariables, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, DataKinds, GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- | A neat effect that you can use to get early returns in your functions. Here's how to use it. -- -- Before: @@ -27,9 +28,9 @@ -- return (x <> y) -- @ -- --- You can use the 'earlyReturn' function directily, or one of the helpers for common use cases. +-- You can use the 'earlyReturn' function directly, or one of the helpers for common use cases. module Control.Effects.Early - ( module Control.Effects, Early + ( module Control.Effects, Early, EffMethods(..) , earlyReturn, handleEarly, onlyDo, ifNothingEarlyReturn, ifNothingDo , ifLeftEarlyReturn, ifLeftDo ) where @@ -38,18 +39,22 @@ import Control.Effects newtype EarlyValue a = EarlyValue { getEarlyValue :: a } -data Early a = Early -data instance Effect (Early a) method mr where - EarlyMsg :: a -> Effect (Early a) 'Early 'Msg - EarlyRes :: { getEarlyRes :: Void } -> Effect (Early a) 'Early 'Res - +data Early a +instance Effect (Early a) where + data EffMethods (Early a) m = EarlyMethods + { _earlyReturn :: forall b. a -> m b } + liftThrough (EarlyMethods f) = EarlyMethods (lift . f) + mergeContext m = EarlyMethods (\a -> do + f <- _earlyReturn <$> m + f a) + instance (Monad m, a ~ b) => MonadEffect (Early a) (ExceptT (EarlyValue b) m) where - effect (EarlyMsg a) = EarlyRes <$> throwE (EarlyValue a) + effect = EarlyMethods (throwE . EarlyValue) -- | Allows you to return early from a function. Make sure you 'handleEarly' to get the actual -- result out. earlyReturn :: forall a b m. MonadEffect (Early a) m => a -> m b -earlyReturn a = fmap (getEarlyValue . absurd . getEarlyRes) . effect $ EarlyMsg a +EarlyMethods earlyReturn = effect -- | Get the result from a computation. Either the early returned one, or the regular result. handleEarly :: Monad m => ExceptT (EarlyValue a) m a -> m a diff --git a/src/Control/Effects/Generic.hs b/src/Control/Effects/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effects/Generic.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, PolyKinds, FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances, TypeOperators, MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications, RankNTypes, DataKinds, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +module Control.Effects.Generic where + +import qualified GHC.Generics as Gen +import GHC.Generics +import Control.Monad.Trans +import Data.Proxy +import GHC.TypeLits + +data M a + +class (Generic (a m), Generic (a (t m)), Generic (a M)) => SimpleMethods a m t where + liftSimple :: a m -> a (t m) + +instance + ( Rep (a m) ~ D1 m1 (C1 m2 p) + , Rep (a M) ~ D1 m1 (C1 m2 pM) + , Rep (a (t m)) ~ D1 m1 (C1 m2 (LiftedProducts p pM m t)) + , ProductOfSimpleMethods p pM m t + , Generic (a m), Generic (a (t m)), Generic (a M) ) + => SimpleMethods a m t where + liftSimple a = case Gen.from a of + M1 (M1 p) -> Gen.to (M1 (M1 (liftProducts (Proxy @m) (Proxy @t) (Proxy @pM) p))) + {-# INLINE liftSimple #-} + +class ProductOfSimpleMethods p pM m t where + type LiftedProducts p pM m t :: * -> * + liftProducts :: Proxy m -> Proxy t -> Proxy pM -> p x -> LiftedProducts p pM m t x + +instance SimpleMethod f fM m t => ProductOfSimpleMethods (S1 m1 (Rec0 f)) (S1 m1 (Rec0 fM)) m t where + type LiftedProducts (S1 m1 (Rec0 f)) (S1 m1 (Rec0 fM)) m t = + (S1 m1 (Rec0 (LiftedMethod f fM m t))) + liftProducts p1 p2 _ (M1 (K1 f)) = M1 (K1 (liftMethod p1 p2 (Proxy @fM) f)) + {-# INLINE liftProducts #-} +instance + (ProductOfSimpleMethods f1 f1M m t, ProductOfSimpleMethods f2 f2M m t) + => ProductOfSimpleMethods (f1 :*: f2) (f1M :*: f2M) m t where + type LiftedProducts (f1 :*: f2) (f1M :*: f2M) m t = + LiftedProducts f1 f1M m t :*: LiftedProducts f2 f2M m t + liftProducts p1 p2 _ (f1 :*: f2) = + liftProducts p1 p2 (Proxy @f1M) f1 :*: liftProducts p1 p2 (Proxy @f2M) f2 + {-# INLINE liftProducts #-} + +class (MonadTrans t, Monad m) => SimpleMethod f fM (m :: * -> *) (t :: (* -> *) -> * -> *) where + type LiftedMethod f fM m t + liftMethod :: Proxy m -> Proxy t -> Proxy fM -> f -> LiftedMethod f fM m t +instance (MonadTrans t, Monad m, a ~ m x) => SimpleMethod a (M x) m t where + type LiftedMethod a (M x) m t = t m x + liftMethod _ _ _ = lift @t + {-# INLINE liftMethod #-} +type family FuncRes f where + FuncRes (a -> b) = b +instance (f ~ (a -> b), SimpleMethod b bM m t, IndependentOfM a m) => SimpleMethod f (a -> bM) m t where + type LiftedMethod f (a -> bM) m t = a -> LiftedMethod (FuncRes f) bM m t + liftMethod p1 p2 _ f a = liftMethod p1 p2 (Proxy @bM) (f a :: b) + {-# INLINE liftMethod #-} +instance {-# OVERLAPPABLE #-} + ( TypeError ('Text "Effect methods must be monadic actions or functions resulting in monadic actions") + , Monad m, MonadTrans t ) + => SimpleMethod a b m t + +class IndependentOfM (a :: k) (m :: * -> *) where +instance + (IndependentOfM a m, IndependentOfM b m) + => IndependentOfM (a b) m +instance + TypeError + ('Text "Parameters of methods can't depend on the monadic context (" + ':<>: 'ShowType m + ':<>: 'Text ")") + => IndependentOfM M m +instance {-# OVERLAPPABLE #-} + IndependentOfM (a :: k) m + +genericLiftThrough :: + forall t e em m. (MonadTrans t, Monad m, Monad (t m), SimpleMethods (em e) m t) + => em e m -> em e (t m) +genericLiftThrough = liftSimple +{-# INLINE genericLiftThrough #-} + + + +class MonadicMethods a m where + mergeMonadicMethods :: m (a m) -> a m +instance + ( Rep (a m) ~ D1 m1 (C1 m2 p) + , Rep (a M) ~ D1 m1 (C1 m2 pM) + , ProductOfMonadicMethods p pM a m + , Generic (a m), Generic (a M) ) + => MonadicMethods a m where + mergeMonadicMethods a = Gen.to (M1 (M1 (mergeMonadicProducts (Proxy @p) (Proxy @pM) a f))) + where + f (Gen.from -> M1 (M1 p)) = p + {-# INLINE mergeMonadicMethods #-} + +class ProductOfMonadicMethods p pM a m where + mergeMonadicProducts :: Proxy p -> Proxy pM -> m (a m) -> (a m -> p x) -> p x +instance MonadicMethod a f fM m => ProductOfMonadicMethods (S1 m1 (Rec0 f)) (S1 m1 (Rec0 fM)) a m where + mergeMonadicProducts _ _ ma f = M1 (K1 (mergeMethod (Proxy @fM) (g . f) ma)) + where + g (M1 (K1 x)) = x + {-# INLINE mergeMonadicProducts #-} +instance + (ProductOfMonadicMethods f1 f1M a m, ProductOfMonadicMethods f2 f2M a m) + => ProductOfMonadicMethods (f1 :*: f2) (f1M :*: f2M) a m where + mergeMonadicProducts _ _ ma f = + mergeMonadicProducts (Proxy @f1) (Proxy @f1M) ma (g1 . f) + :*: mergeMonadicProducts (Proxy @f2) (Proxy @f2M) ma (g2 . f) + where + g1 (x :*: _) = x + g2 (_ :*: x) = x + {-# INLINE mergeMonadicProducts #-} + +class Monad m => MonadicMethod a f fM m where + mergeMethod :: Proxy fM -> (a m -> f) -> m (a m) -> f +instance (b ~ m x, Monad m) => MonadicMethod a b (M x) m where + mergeMethod _ f ma = do + a <- ma + f a + {-# INLINE mergeMethod #-} +instance (f ~ (b -> c), Monad m, MonadicMethod a c cM m) => MonadicMethod a f (bM -> cM) m where + mergeMethod _ f ma b = mergeMethod (Proxy @cM) (g . f) ma + where + g = ($ b) + {-# INLINE mergeMethod #-} +instance {-# OVERLAPPABLE #-} + ( TypeError ('Text "Effect methods must be monadic actions or functions resulting in monadic actions") + , Monad m ) + => MonadicMethod a f fM m + +genericMergeContext :: MonadicMethods a m => m (a m) -> a m +genericMergeContext = mergeMonadicMethods +{-# INLINE genericMergeContext #-} diff --git a/src/Control/Effects/List.hs b/src/Control/Effects/List.hs --- a/src/Control/Effects/List.hs +++ b/src/Control/Effects/List.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, MultiParamTypeClasses #-} -{-# LANGUAGE DataKinds, GADTs #-} +{-# LANGUAGE DataKinds, GADTs, RankNTypes, NoMonomorphismRestriction #-} -- | Add non-determinism to your monad. Uses the 'ListT' transformer under the hood. module Control.Effects.List ( module Control.Effects.List @@ -11,22 +11,26 @@ import ListT hiding (take) import Control.Effects -import Data.Kind -newtype NonDeterministic = Choose Type -data instance Effect NonDeterministic method mr where - ChooseMsg :: { getChooseMsg :: [a] } -> Effect NonDeterministic ('Choose a) 'Msg - ChooseRes :: { getChooseRes :: a } -> Effect NonDeterministic ('Choose a) 'Res +data NonDeterminism +instance Effect NonDeterminism where + data EffMethods NonDeterminism m = NonDeterminismMethods + { _choose :: forall a. [a] -> m a } + liftThrough (NonDeterminismMethods c) = NonDeterminismMethods (lift . c) + mergeContext m = NonDeterminismMethods (\a -> do + lm <- m + _choose lm a) -instance Monad m => MonadEffect NonDeterministic (ListT m) where - effect (ChooseMsg list) = ChooseRes <$> fromFoldable list +-- | Get a value from the list. The choice of which value to take is non-deterministic +-- in a sense that the rest of the computation will be ran once for each of them. +choose :: forall a m. MonadEffect NonDeterminism m => [a] -> m a +NonDeterminismMethods choose = effect --- | Runs the rest of the computation for every value in the list -choose :: MonadEffect NonDeterministic m => [a] -> m a -choose = fmap getChooseRes . effect . ChooseMsg +instance Monad m => MonadEffect NonDeterminism (ListT m) where + effect = NonDeterminismMethods fromFoldable -- | Signals that this branch of execution failed to produce a result. -deadEnd :: MonadEffect NonDeterministic m => m a +deadEnd :: MonadEffect NonDeterminism m => m a deadEnd = choose [] -- | Execute all the effects and collect the result in a list. @@ -56,3 +60,7 @@ -- | Executes only the effects needed to produce a single result. evaluateOneResult :: Monad m => ListT m a -> m (Maybe a) evaluateOneResult = head + +-- | Execute all the effects but discard their results. +evaluateAll :: Monad m => ListT m a -> m () +evaluateAll = void . evaluateToList diff --git a/src/Control/Effects/Reader.hs b/src/Control/Effects/Reader.hs --- a/src/Control/Effects/Reader.hs +++ b/src/Control/Effects/Reader.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts #-} {-# LANGUAGE DataKinds, GADTs #-} +{-# LANGUAGE DeriveGeneric #-} -- | The regular old 'MonadReader' effect with some differences. First, there's no functional -- dependency limiting your stack to a single environment type. This means less type inference so -- it might not be enough to just write 'readEnv'. Write 'readEnv @MyEnvType' instead using @@ -7,22 +8,27 @@ -- -- Second, the function has a less generic name and is called 'readEnv'. -- --- Third, since it's a part of this effect framework, you get a 'handleReadEnv' function with +-- Third, since it's a part of this effect framework, you get a 'implementReadEnv' function with -- which you can provide a different environment implementation _at runtime_. module Control.Effects.Reader (module Control.Effects.Reader, module Control.Effects) where import Control.Effects +import GHC.Generics -data ReadEnv e = ReadEnv -data instance Effect (ReadEnv e) method mr where - ReadEnvMsg :: Effect (ReadEnv e) 'ReadEnv 'Msg - ReadEnvRes :: { getReadEnvRes :: e } -> Effect (ReadEnv e) 'ReadEnv 'Res +data ReadEnv e +instance Effect (ReadEnv e) where + data EffMethods (ReadEnv e) m = ReadEnvMethods + { _readEnv :: m e } + deriving (Generic) +-- | Read a value of type 'e'. Use with the TypeApplications extension to +-- help with type inference +-- @readEnv \@Int@ readEnv :: forall e m. MonadEffect (ReadEnv e) m => m e -readEnv = getReadEnvRes <$> effect ReadEnvMsg - -handleReadEnv :: Functor m => m e -> EffectHandler (ReadEnv e) m a -> m a -handleReadEnv m = handleEffect (\ReadEnvMsg -> ReadEnvRes <$> m) +readEnv = _readEnv effect -handleSubreader :: MonadEffect (ReadEnv e) m => (e -> e') -> EffectHandler (ReadEnv e') m a -> m a -handleSubreader f = handleReadEnv (f <$> readEnv) +-- | Use the given action in the underlying monad to provide environment +-- values. You can think of @implementReadEnv x m@ as replacing all 'readEnv' calls +-- in 'm' with 'x'. +implementReadEnv :: Functor m => m e -> RuntimeImplemented (ReadEnv e) m a -> m a +implementReadEnv m = implement (ReadEnvMethods m) diff --git a/src/Control/Effects/Signal.hs b/src/Control/Effects/Signal.hs --- a/src/Control/Effects/Signal.hs +++ b/src/Control/Effects/Signal.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, Rank2Types, ConstraintKinds #-} {-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, DataKinds, TypeOperators #-} -{-# LANGUAGE GADTs, TypeApplications #-} +{-# LANGUAGE GADTs, DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | This effect allows you to "throw" a signal. For the most part signals are the same as checked -- exceptions. The difference here is that the handler has the option to provide the value that @@ -9,22 +10,28 @@ -- recoverable exceptions at the throw site, instead of just at the handling site. module Control.Effects.Signal ( ResumeOrBreak(..), Signal, throwSignal, handleSignal - , Throws, handleException, handleToEither, module Control.Effects + , Throw, handleException, handleToEither, module Control.Effects , module Control.Monad.Trans.Except, MaybeT(..), discardAllExceptions, showAllExceptions - , Handles(..), handleToEitherRecursive, SomeSignal, signal ) where + , HandleException, handleWithoutDiscarding, handleToEitherRecursive, SomeSignal, signal + , EffMethods(..) ) where -import Import +import Import hiding (liftThrough) import Control.Monad.Trans.Except import qualified GHC.TypeLits as TL import GHC.TypeLits (TypeError, ErrorMessage(..)) import Control.Effects import Control.Monad.Runnable +import GHC.Generics -data Signal a b = Signal -data instance Effect (Signal a b) method mr where - SignalMsg :: a -> Effect (Signal a b) 'Signal 'Msg - SignalRes :: { getSignalRes :: b } -> Effect (Signal a b) 'Signal 'Res +data Signal a b +instance Effect (Signal a b) where + data EffMethods (Signal a b) m = SignalMethods + { _signal :: a -> m b } + deriving (Generic) +signal :: forall a b m. MonadEffect (Signal a b) m => a -> m b +SignalMethods signal = effect + newtype SomeSignal = SomeSignal { getSomeSignal :: Text } deriving (Eq, Ord, Read, Show) type family UnhandledError a b :: ErrorMessage where @@ -37,34 +44,30 @@ ':$$: 'TL.Text "You need to handle all the signals before running the computation" instance {-# OVERLAPPABLE #-} Monad m => MonadEffect (Signal e b) (ExceptT e m) where - effect (SignalMsg a) = throwE a + effect = SignalMethods throwE instance (Show e, Monad m) => MonadEffect (Signal e b) (ExceptT SomeSignal m) where - effect (SignalMsg a) = throwE . SomeSignal . pack . show $ a + effect = SignalMethods (throwE . SomeSignal . pack . show) instance Monad m => MonadEffect (Signal a b) (MaybeT m) where - effect _ = mzero -instance TypeError (UnhandledError a b) - => MonadEffect (Signal a b) IO where + effect = SignalMethods (const mzero) +instance TypeError (UnhandledError a b) => MonadEffect (Signal a b) IO where effect = undefined -instance {-# OVERLAPPING #-} (Monad m, b ~ c) => - MonadEffect (Signal a c) (EffectHandler (Signal a b) m) where - effect msg = EffectHandler (ReaderT (($ msg) . getEffectWithKind)) - -signal :: MonadEffect (Signal a b) m => a -> m b -signal a = getSignalRes <$> effect (SignalMsg a) +instance {-# INCOHERENT #-} (Monad m, b ~ c) => + MonadEffect (Signal a c) (RuntimeImplemented (Signal a b) m) where + effect = mergeContext $ RuntimeImplemented (liftThrough <$> ask) -type Throws e m = MonadEffect (Signal e Void) m +type Throw e = Signal e Void -- | The handle function will return a value of this type. -data ResumeOrBreak b c = Resume b -- ^ Give a value to the caller of 'signal' and keep going. - | Break c -- ^ Continue the execution after the handler. The handler will - -- return this value +data ResumeOrBreak b c = + Resume b -- ^ Give a value to the caller of 'signal' and keep going. + | Break c -- ^ Continue the execution after the handler. The handler will return this value -- | Throw a signal with no possible recovery. The handler is forced to only return the 'Break' -- constructor because it cannot construct a 'Void' value. -- -- If this function is used along with 'handleAsException', this module behaves like regular -- checked exceptions. -throwSignal :: Throws a m => a -> m b +throwSignal :: MonadEffect (Throw a) m => a -> m b throwSignal = fmap absurd . signal resumeOrBreak :: (b -> a) -> (c -> a) -> ResumeOrBreak b c -> a @@ -80,27 +83,26 @@ -- do and continue execution after the handler. handleSignal :: forall a b c m. Monad m => (a -> m (ResumeOrBreak b c)) - -> EffectHandler (Signal a b) (ExceptT c m) c + -> RuntimeImplemented (Signal a b) (ExceptT c m) c -> m c handleSignal f = fmap collapseEither - . runExceptT - . handleEffect h + . runExceptT + . implement (SignalMethods h) where - h :: forall method. Effect (Signal a b) method 'Msg -> ExceptT c m (Effect (Signal a b) method 'Res) - h (SignalMsg a) = do + h a = do rb <- lift (f a) - resumeOrBreak (return . SignalRes) throwE rb + resumeOrBreak return throwE rb -- | This handler can only behave like a regular exception handler. If used along with 'throwSignal' -- this module behaves like regular checked exceptions. -handleException :: Monad m => (a -> m c) -> ExceptT a m c -> m c +handleException :: forall a c m. Monad m => (a -> m c) -> ExceptT a m c -> m c handleException f = either f return <=< runExceptT -- | See documentation for 'handleException'. This handler gives you an 'Either'. -handleToEither :: ExceptT e m a -> m (Either e a) +handleToEither :: forall e a m. ExceptT e m a -> m (Either e a) handleToEither = runExceptT --- | Discard all the 'Throws' and 'Signal' constraints. If any exception was thrown +-- | Discard all the 'Throw' and 'Signal' effects. If any exception was thrown -- the result will be 'Nothing'. discardAllExceptions :: MaybeT m a -> m (Maybe a) discardAllExceptions = runMaybeT @@ -109,53 +111,61 @@ mapLeft f (Left a) = Left (f a) mapLeft _ (Right b) = Right b --- | Satisfies all the 'Throws' and 'Signal' constraints /if/ they all throw 'Show'able +-- | Satisfies all the 'Throw' and 'Signal' constraints /if/ they all throw 'Show'able -- exceptions. The first thrown exception will be shown and returned as a 'Left' result. showAllExceptions :: Functor m => ExceptT SomeSignal m a -> m (Either Text a) showAllExceptions = fmap (mapLeft getSomeSignal) . runExceptT --- | A class of monads that throw and catch exceptions of type @e@. An overlappable instance is --- given so you just need to make sure your transformers have a 'RunnableTrans' instance. -class Throws e m => Handles e m where - -- | Use this function to handle exceptions without discarding the 'Throws' constraint. - -- You'll want to use this if you're writing a recursive function. Using the regular handlers - -- in that case will result with infinite types. - -- - -- Since this function doesn't discard constraints, you still need to handle the whole thing. - -- - -- Here's a slightly contrived example. - -- - -- @ - -- data NotFound = NotFound - -- data Tree a = Leaf a | Node (Tree a) (Tree a) - -- data Step = GoLeft | GoRight - -- findIndex :: (Handles NotFound m, Eq a) => a -> Tree a -> m [Step] - -- findIndex x (Leaf a) | x == a = return [] - -- | otherwise = throwSignal NotFound - -- findIndex x (Node l r) = ((GoLeft :) <$> findIndex x l) - -- & handleRecursive (\NotFound -> (GoRight :) <$> findIndex x r) - -- @ - -- - -- Note: When you finally handle the exception effect, the order in which you handle it and - -- other effects determines whether 'handleRecursive' rolls back other effects if an exception - -- occured or it preserves all of them up to the point of the exception. - -- Handling exceptions last and handling them first will produce the former and latter - -- behaviour respectively. - handleRecursive :: (e -> m a) -> m a -> m a - -instance Monad m => Handles e (ExceptT e m) where - handleRecursive f = ExceptT . (either (runExceptT . f) (return . Right) <=< runExceptT) - {-# INLINE handleRecursive #-} - -instance {-# OVERLAPPABLE #-} (Monad m, Monad (t m), Handles e m, RunnableTrans t) - => Handles e (t m) where - handleRecursive f e = do +data HandleException e +instance Effect (HandleException e) where + data EffMethods (HandleException e) m = HandleExceptionMethods + { _handleWithoutDiscarding :: forall a. (e -> m a) -> m a -> m a } + type CanLift (HandleException e) t = RunnableTrans t + liftThrough :: + forall t m. (CanLift (HandleException e) t, Monad m, Monad (t m)) + => EffMethods (HandleException e) m -> EffMethods (HandleException e) (t m) + liftThrough (HandleExceptionMethods rec') = HandleExceptionMethods $ \f e -> do st <- currentTransState - res <- lift (handleRecursive (\ex -> runTransformer (f ex) st) (runTransformer e st)) + res <- lift (rec' (\ex -> runTransformer (f ex) st) (runTransformer e st)) restoreTransState res - {-# INLINE handleRecursive #-} + mergeContext m = HandleExceptionMethods $ \f ex -> do + g <- _handleWithoutDiscarding <$> m + g f ex +-- | Use this function to handle exceptions without discarding the 'Throw' effect. +-- You'll want to use this if you're writing a recursive function. Using the regular handlers +-- in that case will result with infinite types. +-- +-- Since this function doesn't discard constraints, you still need to handle the exception on +-- the whole computation. +-- +-- Here's a slightly contrived example. +-- +-- @ +-- data NotFound = NotFound +-- data Tree a = Leaf a | Node (Tree a) (Tree a) +-- data Step = GoLeft | GoRight +-- findIndex :: (Handles NotFound m, Eq a) => a -> Tree a -> m [Step] +-- findIndex x (Leaf a) | x == a = return [] +-- | otherwise = throwSignal NotFound +-- findIndex x (Node l r) = ((GoLeft :) <$> findIndex x l) +-- & handleWithoutDiscarding (\NotFound -> (GoRight :) <$> findIndex x r) +-- @ +-- +-- Note: When you finally handle the exception effect, the order in which you handle it and +-- other effects determines whether 'handleWithoutDiscarding' rolls back other effects if an exception +-- occured or it preserves all of them up to the point of the exception. +-- Handling exceptions last and handling them first will produce the former and latter +-- behaviour respectively. +handleWithoutDiscarding :: + forall e m a. MonadEffect (HandleException e) m => (e -> m a) -> m a -> m a +HandleExceptionMethods handleWithoutDiscarding = effect + +instance Monad m => MonadEffect (HandleException e) (ExceptT e m) where + effect = HandleExceptionMethods $ \f -> + ExceptT . (either (runExceptT . f) (return . Right) <=< runExceptT) + -- | 'handleToEither' that doesn't discard 'Throws' constraints. See documentation for --- 'handleRecursive'. -handleToEitherRecursive :: Handles e m => m a -> m (Either e a) -handleToEitherRecursive = handleRecursive (return . Left) . fmap Right +-- 'handleWithoutDiscarding'. +handleToEitherRecursive :: MonadEffect (HandleException e) m => m a -> m (Either e a) +handleToEitherRecursive = handleWithoutDiscarding (return . Left) . fmap Right diff --git a/src/Control/Effects/State.hs b/src/Control/Effects/State.hs --- a/src/Control/Effects/State.hs +++ b/src/Control/Effects/State.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, Rank2Types, ConstraintKinds #-} +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses, GADTs #-} -{-# LANGUAGE DataKinds, TypeInType #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- | The 'MonadState' you know and love with some differences. First, there's no functional -- dependency limiting your stack to a single state type. This means less type inference so -- it might not be enough to just write 'getState'. Write 'getState @MyStateType' instead using @@ -8,59 +11,63 @@ -- -- Second, the functions have less generic names and are called 'getState' and 'setState'. -- --- Third, since it's a part of this effect framework, you get a 'handleState' function with +-- Third, since it's a part of this effect framework, you get an 'implement' function with -- which you can provide a different state implementation _at runtime_. module Control.Effects.State (module Control.Effects.State, module Control.Effects) where import Import hiding (State) import Data.IORef +import GHC.Generics import Control.Effects -data State s = Get | Set -data instance Effect (State s) method mr where - GetStateMsg :: Effect (State s) 'Get 'Msg - GetStateRes :: { getGetStateRes :: s } -> Effect (State s) 'Get 'Res - SetStateMsg :: s -> Effect (State s) 'Set 'Msg - SetStateRes :: Effect (State s) 'Set 'Res +data State s -instance Monad m => MonadEffect (State s) (StateT s m) where - effect GetStateMsg = GetStateRes <$> get - effect (SetStateMsg s) = SetStateRes <$ put s - {-# INLINE effect #-} +instance Effect (State s) where + data EffMethods (State s) m = StateMethods + { _getState :: m s + , _setState :: s -> m () } + deriving (Generic) +-- | Get current value of the state with the type 's'. +-- You can use type applications to tell the type checker which type of state you want. +-- @getState \@Int@ getState :: forall s m. MonadEffect (State s) m => m s -getState = getGetStateRes <$> effect GetStateMsg -{-# INLINE getState #-} - +-- | Set a new value for the state of type 's' +-- You can use type applications to tell the type checker which type of state you're setting. +-- @setState \@Int 5@ setState :: forall s m. MonadEffect (State s) m => s -> m () -setState s = void $ effect (SetStateMsg s) -{-# INLINE setState #-} +StateMethods getState setState = effect +-- | Transform the state of type 's' using the given function. +-- You can use type applications to tell the type checker which type of state you're modifying. +-- @modifyState \@Int (+ 1)@ modifyState :: forall s m. MonadEffect (State s) m => (s -> s) -> m () modifyState f = do - s <- getState - let s' = f s in s' `seq` setState s' -{-# INLINE modifyState #-} + s <- getState @s + let s' = f s + s' `seq` setState s' --- | Handle the 'MonadEffect (State s)' constraint by providing custom handling functions. -handleState :: forall m s a. Monad m => m s -> (s -> m ()) - -> EffectHandler (State s) m a -> m a -handleState getter setter = - handleEffect handler - where handler :: forall method. Effect (State s) method 'Msg -> m (Effect (State s) method 'Res) - handler GetStateMsg = GetStateRes <$> getter - handler (SetStateMsg s) = SetStateRes <$ setter s -{-# INLINE handleState #-} +instance Monad m => MonadEffect (State s) (StateT s m) where + effect = StateMethods get put --- | Handle the state requirement using an 'IORef'. -handleStateIO :: MonadIO m => s -> EffectHandler (State s) m a -> m a -handleStateIO initial m = do +-- | Implement the state effect via the StateT transformer. If you have a function with a type like +-- @f :: MonadEffect (State Int) m => m ()@ you can use 'implementStateViaStateT' to satisfy the +-- 'MonadEffect' constraint. +-- +-- @implementStateViaStateT \@Int 0 f :: Monad m => m ()@ +implementStateViaStateT :: forall s m a. Monad m => s -> StateT s m a -> m a +implementStateViaStateT = flip evalStateT + +-- | Handle the state requirement using an 'IORef'. If you have a function with a type like +-- @f :: MonadEffect (State Int) m => m ()@ you can use 'implementStateViaIORef' to replace the +-- 'MonadEffect' constraint with 'MonadIO'. This is convenient if you already have a 'MonadIO' +-- constraint and you don't want to use the 'StateT' transformer for some reason. +-- +-- @implementStateViaIORef \@Int 0 f :: MonadIO m => m ()@ +implementStateViaIORef :: forall s m a. MonadIO m => s -> RuntimeImplemented (State s) m a -> m a +implementStateViaIORef initial m = do ref <- liftIO (newIORef initial) - m & handleState (liftIO (readIORef ref)) (liftIO . writeIORef ref) -{-# INLINE handleStateIO #-} + m & implement (StateMethods (liftIO (readIORef ref)) (liftIO . writeIORef ref)) +{-# INLINE implementStateViaIORef #-} --- | Handle the state requirement using the standard 'StateT' transformer. -handleStateT :: Monad m => s -> StateT s m a -> m a -handleStateT = flip evalStateT -{-# INLINE handleStateT #-} diff --git a/src/Control/Monad/Runnable.hs b/src/Control/Monad/Runnable.hs --- a/src/Control/Monad/Runnable.hs +++ b/src/Control/Monad/Runnable.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies, UndecidableInstances, ScopedTypeVariables, FlexibleInstances #-} -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification, DefaultSignatures #-} {-# OPTIONS_GHC -Wno-warnings-deprecations #-} module Control.Monad.Runnable where @@ -37,12 +37,18 @@ -- 'runTransformer' function. runMonad :: MonadicState m -> m a -> IO (MonadicResult m a) + default runMonad :: PureRunnable m => MonadicState m -> m a -> IO (MonadicResult m a) + runMonad s m = return (runPureMonad s m) + +class Runnable m => PureRunnable m where + runPureMonad :: MonadicState m -> m a -> MonadicResult m a + -- | A class of transformers that can run their effects in the underlying monad. -- -- The following laws need to hold. -- -- @ --- \t -> do st <- 'currentTransState' +-- \\t -> do st <- 'currentTransState' -- res <- 'lift' ('runTransformer' t st) -- 'restoreTransState' res -- == 'id' @@ -50,7 +56,7 @@ -- -- @ -- f :: (forall a. m a -> m a) --- \m s -> runTransformer (lift (f m)) s == \m s -> f (runTransformer (lift m) s) +-- \\m s -> runTransformer (lift (f m)) s == \\m s -> f (runTransformer (lift m) s) -- @ class MonadTrans t => RunnableTrans t where -- | The type of value that needs to be provided to run this transformer. @@ -59,7 +65,7 @@ type TransformerResult t (m :: * -> *) a :: * -- | Get the current state value. currentTransState :: Monad m => t m (TransformerState t m) - -- | If given a result, reconstruct the compitation. + -- | If given a result, reconstruct the computation. restoreTransState :: Monad m => TransformerResult t m a -> t m a -- | Given the required state value and a computation, run the effects of the transformer -- in the underlying monad. @@ -70,8 +76,10 @@ type MonadicResult Identity a = a currentMonadicState = return () restoreMonadicState = return - runMonad _ (Identity a) = return a +instance PureRunnable Identity where + runPureMonad _ (Identity a) = a + instance Runnable IO where type MonadicState IO = () type MonadicResult IO a = a @@ -85,6 +93,9 @@ currentMonadicState = (,) <$> currentTransState <*> lift currentMonadicState restoreMonadicState s = lift (restoreMonadicState s) >>= restoreTransState runMonad (s, s') t = runMonad s' (runTransformer t s) + +instance (PureRunnable m, RunnableTrans t, Monad (t m)) => PureRunnable (t m) where + runPureMonad (s, s') t = runPureMonad s' (runTransformer t s) instance RunnableTrans (SS.StateT s) where type TransformerState (SS.StateT s) m = s diff --git a/src/Tutorial/T1_Introduction.hs b/src/Tutorial/T1_Introduction.hs new file mode 100644 --- /dev/null +++ b/src/Tutorial/T1_Introduction.hs @@ -0,0 +1,234 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-| This part of the tutorial will explain the basics behind @simple-effects@ and how to use the + effects provided by the library. To learn how to implement your own effects, check out the other + parts. + + You'll need to enable some extensions to follow along: @TypeApplications@, @FlexibleContexts@, + @OverloadedStrings@, @DataKinds@. +-} +module Tutorial.T1_Introduction ( + -- * State + -- $state + + -- * Non-determinism + -- $nondeterminism + + -- * Order + -- $order + ) where + +import Data.Text as T +import Data.Text.IO as T +import Control.Monad.IO.Class +import Control.Effects.State +import Control.Effects.List +{- $state + Let's say we're writing a function that asks the user to name a fruit and adds their answer to + a list of already known fruits. Here's what we want to do (in pseudocode) + +@ +addFruit = do + fruit <- ask "Name a type of fruit please" + knownFruits <- getCurrentlyKnownFruits + setCurrentlyKnownFruits (fruit : knownFruits) +@ + + Our function needs to get input from the user, so we'll need a way to do IO. It also modifies + a piece of state: a list of fruits. We state those requirements in the signature. + +@ +addFruit :: ('MonadIO' m, 'MonadEffect' ('State' ['Text']) m) => m () +@ + + The 'MonadIO' constraint comes from "Control.Monad.IO.Class" of the @transformers@ package and + it lets us do IO without forcing our monad to be 'IO'. + + The other constraint, 'MonadEffect', is how you specify effects using this library. It says that + to run @addFruit@ you need to provide an implementation for a state holding a list of 'Text's. + + Here's how we might define the @addFruit@ function. + +@ +addFruit :: ('MonadIO' m, 'MonadEffect' ('State' ['Text']) m) => m () +addFruit = do + 'liftIO' ('T.putStrLn' "Name a type of fruit please") + fruit <- 'liftIO' 'T.getLine' + knownFruits <- 'getState' + 'setState' (fruit : knownFruits) +@ + + [Note] + It's possible to have more than one state available to use. Since 'getState' and 'setState' + need to work with all of them you'll sometimes need to specify the type of state you want to get/set. + In the above case we didn't need to since the compiler can infer that our state is @['Text']@. + It infers @fruit :: 'Text'@ from the signature of 'T.getLine' and it can infer the list part + since we're using the list cons operator. + + To help the type checker in cases where it can't infer the types, it's convenient to use the + @TypeApplications@ extension. With it, we can write @fruit <- 'getState' \@['Text']@ and + @'setState' \@['Text'] (fruit : knownFruits)@ to be explicit about which state type we mean. + + + So lets use our function to ask for three types of fruit. After than we want to print the list. + +@ +-- this doesn't work yet +main :: 'IO' () +main = do + addFruit + addFruit + addFruit + fruits <- 'getState' \@['Text'] + 'liftIO' ('print' fruits) +@ + + This almost works but we still need to provide an implementation of the state. The simplest way + to do that is the 'implementStateViaStateT' function. It takes an initial value, and a computation + that has a state requirement, and it satisfies that requirement. In this case, the initial + value will be an empty list, and the computation will be our whole do block. + +@ +main :: 'IO' () +main = 'implementStateViaStateT' \@['Text'] [] $ do + addFruit + addFruit + addFruit + fruits <- 'getState' \@['Text'] + 'liftIO' ('print' fruits) +@ + + This should work. The reason we don't need to to anything about the 'MonadIO' constraint is + because the fact that the final result is in the 'IO' monad automatically satisfies it. + + Another thing that we can do with the 'State' effect (and all the other ones provided by the + @simple-effects@ library) is provide a custom implementation that can depend on runtime values. + + Lets imagine that we have a database and two functions: + +@ +getFruits :: 'MonadIO' m => Connection -> m ['Text'] +setFruits :: 'MonadIO' m => Connection -> ['Text'] -> m () +@ + + These should get a list of fruits from the database, and store a new list back into it. We can + use the exact same code as above, just changing the part that implements the state: + +@ +main :: 'IO' () +main = do + conn <- connectToDb "my-connection-string" + 'implement' ('StateMethods' (getFruits conn) (setFruits conn)) $ do + addFruit + addFruit + addFruit + fruits <- 'getState' \@['Text'] + 'liftIO' ('print' fruits) +@ + + And now suddenly our fruit list persists between sessions. We can do the same but instead talk + to some remote API, or read/write from a file, or use a shared variable and run multiple + computations at the same time... + +-} + +{- $nondeterminism + Now lets add an additional effect into the mix. For example, we an use the 'NonDeterminism' effect. + +@ +main :: 'IO' () +main = + 'evaluateAll' $ + 'implementStateViaStateT' \@['Text'] [] $ do + addFruit + addFruit + addFruit + fruits <- 'getState' \@['Text'] + fruit <- 'choose' fruits + 'liftIO' ('print' fruit) +@ + + The 'choose' function non-deterministically picks one fruit from the list and prints it. When + we use it, our @do@ block gets a new constraint. It's type is now + +@ +('MonadIO' m, 'MonadEffect' ('State' ['Text']) m, 'MonadEffect' 'NonDeterminism' m) => m () +@ + + Therefore we need to provide an implementation of the 'NonDeterminism' effect before we run the + whole thing. This is what the 'evaluateAll' function does. It runs the computation for each + non-deterministic possibility, meaning all the fruit will get printed. + + [Note] Instead of repeating 'MonadEffect' for each effect, you can use the 'MonadEffects' + type family and give it a list of effects instead. Like this + @('MonadIO' m, 'MonadEffects' \'['State' ['Text'], 'NonDeterminism'] m) => m ()@ + +-} + +{- $order + One thing to note is that the order in which you implement effects sometimes matters. + For example, handling state first and then non-determinism after will result in the state + being forked on each non-deterministic branch. Doing it in the reverse order will make the + state shared between branches meaning that changes in one branch will affect the state when the + next branch is taken. Here's an example + +@ +main :: IO () +main = do + 'evaluateAll' $ + 'implementStateViaStateT' \@Int 0 $ do + 'setState' \@Int 1 + 'choose' ('Prelude.replicate' 3 ()) + 'setState' . 'succ' =<< 'getState' \@Int + 'liftIO' . 'print' =<< 'getState' \@Int + 'Prelude.putStrLn' "" + 'implementStateViaStateT' \@Int 0 $ + 'evaluateAll' $ do + 'setState' \@Int 1 + 'choose' ('Prelude.replicate' 3 ()) + 'setState' . 'succ' =<< 'getState' \@Int + 'liftIO' . 'print' =<< 'getState' \@Int +@ + The first run prints @2 2 2@ because the state is handled first, while the second run prints + @2 3 4@. A useful way to get an intuitive understanding of which order does what is to consider + that in the second case, after we handle non-determinism we can still get the state value because + we have yet to handle that effect. But if state was forked on each choice there could be many + possible state values after the whole computation finishes. Which one would 'getState' return? + The only way it makes sense is if the state is shared since it keeps things unambiguous. + + On the other hand maybe we do want to see all the possible end states. The following example + demonstrates how the two orderings let us do those two things. + +@ +main4 :: IO () +main4 = do + lst <- 'evaluateToList' $ + 'implementStateViaStateT' \@Int 0 $ do + 'setState' \@Int 1 + 'choose' ('Prelude.replicate' 3 ()) + 'setState' . 'succ' =<< 'getState' \@Int + 'getState' \@Int + 'print' lst + 'implementStateViaStateT' \@Int 0 $ do + 'evaluateAll' $ do + 'setState' \@Int 1 + 'choose' ('Prelude.replicate' 3 ()) + 'setState' . 'succ' =<< 'getState' \@Int + 'liftIO' . 'print' =<< 'getState' \@Int +@ + + The first run gets the state value at the end. This will be the end state for each fork. This + value becomes the result of the whole 'implementStateViaStateT' block but since we still need + to handle the non-determinism, this whole block is also ran once for each possible branch. + Finally, we collect all the results in a list using the 'evaluateToList' function. This handles + the non-determinism. + + In the second run we get the state /after/ handling non-determinism. This gives us the final + value of the state shared between all the branches. + + This concludes the first part of the tutorial. To see how other effects are used, check out the + examples and the documentation of their respective modules. + + If you want a more in-depth look into the inner workings of this library, continue to the second + part of the tutorial: "Tutorial.T2_Details". We'll look at implementing custom effects in part 3, + "Tutorial.T3_CustomEffects". +-} diff --git a/src/Tutorial/T2_Details.hs b/src/Tutorial/T2_Details.hs new file mode 100644 --- /dev/null +++ b/src/Tutorial/T2_Details.hs @@ -0,0 +1,288 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-| In this part, we'll take a more detailed look at this library. You don't need to know these + things to use the effects. For the most part, you can also implement your own without reading + this part. To learn about that check out the next part: "Tutorial.T3_CustomEffects". + + That being said, the details will help you understand potential compiler errors you might get. + Also, implementing more complex effects does require a bit of an understanding of the internals. +-} + +module Tutorial.T2_Details ( + -- * Transformers + -- $transformers + + -- * The 'Effect' class + -- $effect + + -- * The 'MonadEffect' class + -- $monadeffect + + -- * Runtime implementation + -- $runtime + ) where + +import Control.Effects +import Control.Effects.State +import Control.Monad.Trans.State as S hiding (State) +import Control.Monad.Trans.Reader as R +import Control.Monad.Trans as T (lift, MonadTrans) +import GHC.Generics +{- $transformers + Monad transformers are types with the kind @(\* -> \*) -> \* -> \*@ that take a monad as a + parameter and add some extra functionality on top of it, resulting in a new monad. This isn't a + tutorial on them so we'll just briefly go through the basics. + + Since a transformer takes a monad and produces a new monad, they can stack on top of each other + forming \'transformer stacks\'. The functions that utilize a transformer @t@\'s functionality only + work directly if @t@ is the topmost transformer on the stack. Since there can obviously only be + one transformer on the top, and we want to use more than one effect, we need to 'T.lift' their + functions through the stack. For example: +@ +'S.get' :: 'Monad' m => 'StateT' s m s +@ + so if we want to use this function in a stack that has a 'ReaderT' transformer on top we need to + use 'T.lift': + +@ +'T.lift' 'S.get' :: 'Monad' m => 'ReaderT' r ('StateT' s m) s +@ + + If you imagine we had 5 additional layers above the 'ReaderT', we'd need to call 'T.lift' 5 more + times. Instead we use type classes with polymorphic functions that work over any transformer + stack. Their instances are arranged in a way that automatically calls 'T.lift' as many times as + needed. For example, the 'getState' function in @simple-effects@ has the type + @'MonadEffect' ('State' s) m => m s@. Let's say our stack is + @'ReaderT' r1 ('ReaderT' r2 ('StateT' s 'IO'))@. The reason why we can use the 'getState' + function is because there are two instances for @'MonadEffect' ('State' s)@. + +@ +instance 'MonadEffect' ('State' s) ('StateT' s m) +@ + + and + +@ +instance 'MonadEffect' ('State' s) m => 'MonadEffect' ('State' s) ('ReaderT' r m) +@ + + Instance resolution first matches the second instance and sees that it requires a + @'MonadEffect' ('State' s)@ from the underlying monad @m@. Then it again encounters a + 'ReaderT' and finally it arrives at the 'StateT' layer that has no other requirements. + The actual implementation for the 'ReaderT' instance does the 'T.lift'ing while the 'StateT' + implementation actually uses the structure of the 'StateT' transformer to implement the + required function. + + [Note] + This is a bit of a simplification. There isn't really a + @'MonadEffect' ('State' s) ('ReaderT' r m)@ instance, but instead a more general + @'MonadEffect' e (t m)@ one that works for any transformer and any effect. It's an + @OVERLAPPABLE@ instance so more specific ones can be chosen if they exist (as is the case + with, for example, the 'StateT' instance for the 'State' effect) + + Now let's see how a function like 'implementStateViaStateT' works. It's type is + @'implementStateViaStateT' \@Int :: 'Monad' m => Int -> 'StateT' Int m a -> m a@. Say we also have a + computation with the type @'MonadEffect' ('State' Int) n => n ()@ that we want to run. If we + give that computation as the second parameter of the 'implementStateViaStateT' function then @n@ + becomes @'StateT' Int m a@, but since there was also a constraint on the @n@ type, instance + resolution must check if that type satisfies it. This then finds the + @instance 'MonadEffect' ('State' s) ('StateT' s m)@ instance and everything works. Then finally + the actual definition of 'implementStateViaStateT' kicks in and it runs the 'StateT' transformer, + giving it an initial state value and resulting in a monadic action that's free of the state + constraint. + + If we had additional effect constraints on our initial computation, then the instance resolution + would find the matching instances for the 'StateT' transformer that would push the constraint + onto the underlying monad. This means that our final result wouldn't just have a 'Monad' + constraint, but also those other ones that remain to be handled. + + What @simple-effects@ does is provide a structured way to define new effects so that they can + automatically be lifted through monad stacks. Also, for the more complex effects where just + 'lift' isn't enough, it enables the writer of the effect to specify how exactly to lift their + effect. This is done through the 'Effect' class. +-} +{- $effect + The core of every effect is it's 'Effect' instance. Here's how the class is defined: + +@ +class 'Effect' e where + data 'EffMethods' e (m :: * -> *) :: * + type 'CanLift' e (t :: (* -> *) -> * -> *) :: 'Constraint' + type 'CanLift' e t = 'MonadTrans' t + 'liftThrough' :: + ('CanLift' e t, 'Monad' m, 'Monad' (t m)) + => 'EffMethods' e m -> 'EffMethods' e (t m) + 'mergeContext' :: 'Monad' m => m ('EffMethods' e m) -> 'EffMethods' e m +@ + + The 'EffMethods' associated data type is where you specify the functionality that your effect + provides. This will be a record of monadic functions. For example, there's how it's instantiated + for the state effect: + +@ +data 'EffMethods' ('State' s) m = 'StateMethods' + { '_getState' :: m s + , '_setState' :: s -> m () } +@ + + Then there's the 'CanLift' type. It specifies the constraint that a transformer needs to satisfy + to be able to lift the effect through it. Usually, 'MonadTrans' is all you need, so that's the + default instantiation. Some more complicated effects have tighter demands. + + The 'liftThrough' function gets an implementation of the effect @e@ in the monad @m@ and is + required to provide an implementation in the monad @t m@. Here's how it might look for the + 'State' effect. + +@ +'liftThrough' ('StateMethods' g s) = 'StateMethods' ('lift' g) ('lift' . s) +@ + + As you can see, 'MonadTrans' is enough in this case since the 'lift' function is all we need. + + Finally, the 'mergeContext' method. Given a record of methods in a monadic context, give me a + new record of methods that somehow merges that context into it. The way it's implemented is + simpler than it seems. For example, let's see how we'd implement a function with the following + signature: @f :: m (a -> m b) -> a -> m b@ + + Since our result is monadic we're free to just bind that inner function and give it the extra + parameter like this: + +@ +f mamb a = do + amb <- mamb + amb a +@ + + If we had more than one function inside of the context, we'd just need to select the correct one + after binding it. Here's how 'mergeContext' is implemented for the 'State' effect. + +@ +'mergeContext' m = 'StateMethods' + { '_getState' = do + sm <- m + '_getState' sm + , '_setState' s = do + sm <- m + '_setState' sm s } +@ + + If these implementations seem pretty mechanical it's because they are. So mechanical, in fact, + that in most of the cases you don't even need to write them. Just derive the 'Generic' class + for your effect and you get those definitions for free. Here's the actual instance + @'Effect' ('State' s)@: + +@ +instance 'Effect' ('State' s) where + data 'EffMethods' ('State' s) m = 'StateMethods' + { '_getState' :: m s + , '_setState' :: s -> m () } + deriving ('Generic') +@ + + There are a couple of conditions though. The automatic method deriving only works for what + is called, in the terminology of this library, a simple effect. The methods of a simple effect + are functions that take arguments that don't depend on the monad @m@ and also have a monadic + result in that monad. For example, @'setState' :: s -> m ()@ is a method of a simple effect + while @g :: m a -> m a@ isn't one because the first parameter depends on @m@. + + One extra condition is that there can't be any universally quantified variables in the methods, + so for example if your effect has a method @h :: forall a. a -> m ()@, you can't derive + 'liftThrough' and 'mergeContext' for it automatically. This isn't because it's impossible + (or even difficult), but because you can't derive 'Generic' for those types. In those cases + you need to write the implementations yourself. + + Finally, we have the 'MonadEffect' class. +-} + +{- $monadeffect + It's defined like this + +@ +class ('Effect' e, 'Monad' m) => 'MonadEffect' e m where + 'effect' :: 'EffMethods' e m +@ + + So it just says that monads that implement the effect @e@ need to provide a record of + the effect's methods that work in that monad. + + As discussed in the transformers section, there's an + overlappable instance given for the 'MonadEffect' class. Here it is: + +@ +instance \{\-\# OVERLAPPABLE \#\-\} + ('MonadEffect' e m, 'Monad' (t m), 'CanLift' e t) => 'MonadEffect' e (t m) where + 'effect' = 'liftThrough' 'effect' +@ + + It means that any transformer @t@ can implement the effect @e@ as long as the underlying monad + can implement it /and/ the transformer satisfies the conditions that the effect imposes on it + (in most cases, the 'MonadTrans' constraint). + + Transformers that finally implement the effect have specific 'MonadEffect' instances. For + example: + +@ +instance 'Monad' m => 'MonadEffect' ('State' s) ('StateT' s m) where + 'effect' = 'StateMethods' 'S.get' 'S.put' +@ + + [Note] + The 'S.get' and 'S.put' functions come from the "Control.Monad.Trans.State" module. +-} + +{- $runtime + Defining effects in a structured way like this has an additional benefit. It lets us use + implementations that we construct at runtime! This is achieved through the 'RuntimeImplemented' + type. 'RuntimeImplemented' is a special transformer defined like this: + +@ +newtype 'RuntimeImplemented' e m a = 'RuntimeImplemented' + { 'getRuntimeImplemented' :: 'ReaderT' ('EffMethods' e m) m a } +@ + + It's a wrapper around a 'ReaderT' that carries around an @'EffMethods' e m@ record. + @'RuntimeImplemented' e@ has a @'MonadEffect' e@ instance defined like this + +@ +instance ('Effect' e, 'Monad' m, 'CanLift' e ('RuntimeImplemented' e)) + => 'MonadEffect' e ('RuntimeImplemented' e m) where + 'effect' = 'mergeContext' $ 'RuntimeImplemented' ('liftThrough' <$> 'ask') +@ + + Essentially, 'ask' gives us the record, but it's inside of a monadic context so we need + 'mergeContext' to get it out. This lets us implement any effect /at runtime/ using the + 'implement' function: + +@ +'implement' :: forall e m a. 'EffMethods' e m -> 'RuntimeImplemented' e m a -> m a +'implement' em ('RuntimeImplemented' r) = 'runReaderT' r em +@ + + As with 'implementStateViaStateT', when we give our polymorphic monadic action as a second + parameter, instance resolution checks if @'RuntimeImplemented' e m a@ has instances for all the + effects we need. Most of them just propagate through to the inner @m@ monad, but the effect @e@ + that we're implementing finds the instance above and uses that reader's environment to get the + effect's methods. All that's left is to actually run the 'ReaderT' by giving it the record which + we're free to construct any way we want. + + [Note] + One more thing. You might notice that the definition of the state effect doesn't mention the + 'getState' and 'setState' functions. The methods in the record are called '_getState' and + '_setState', with an underscore. If you think about it you'll see that to actually use one + of them, we first need to get them out of the record. Since we can access the record of + methods for the current monad with the 'effect' function, getting the current state would + look like @'_getState' 'effect'@ so to reduce duplication it's convenient to define helpers + like @'getState' = '_getState' 'effect'@ and @'setState' = '_setState' effect@. Even simpler, + though arguably more magical, is the following top level definition + + @ + 'StateMethods' 'getState' 'setState' = 'effect' + @ + + When we write that at the top level, we bind the first field in the 'effect' record to the + 'getState' name and the second field to the 'setState' name. It's pretty weird because we're + not in any specific monad, yet we're still somehow unpacking the record. Still, 'getState', + for example, happily accepts the @'MonadEffect' ('State' s) m => m s@ type signature and + it just works. + + That's pretty much it. In the next part we'll take a look at implementing our own effects. +-} diff --git a/src/Tutorial/T3_CustomEffects.hs b/src/Tutorial/T3_CustomEffects.hs new file mode 100644 --- /dev/null +++ b/src/Tutorial/T3_CustomEffects.hs @@ -0,0 +1,419 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-| Let's see how we can implement custom effects. We'll go through a couple of examples of + increasing complexity. This part does not require going through part 2. That being said, + understanding the details will help with understanding some of the restrictions and will help + with compiler errors you might get. +-} +module Tutorial.T3_CustomEffects ( + -- * Files + -- $files + + -- * Implementations + -- $implement + + -- * Print + -- $print + + -- * Fork + -- $fork + ) where +import Control.Effects +import Control.Effects.State +import Control.Monad.Trans.State as S hiding (State) +import Control.Monad.Trans.Reader as R +import Control.Monad.Trans as T (lift, MonadTrans) +import GHC.Generics +import Data.Text +import Data.ByteString as B +import Control.Monad.IO.Class +import Control.Concurrent +{- $files + To start off, we'll define an effect for working with the filesystem. To keep it simple, we'll + define two functions. One for reading the contents of a file, and one for writing them to a file. + + The first step is to make a name for our effect. Say, @Files@ for example. We declare an empty + datatype with that name: + +@ +data Files +@ + + Next, we need to provide an instance of the 'Effect' class for our effect. + + The signatures of our functions will be @'FilePath' -> m 'ByteString'@ and + @'FilePath' -> 'ByteString' -> m ()@ respectively. Both of them are methods of what we call, in the + jargon of this library, a simple effect. It means that they are functions that return a monadic + action, and that their arguments don't depend on that monad. As an example, @m Int -> m Int@ + isn't a method of a simple effect because the argument depends on @m@. + + Because of this fact, the instance is super simple: + +@ +instance 'Effect' Files where + data 'EffMethods' Files m = FilesMethods + { _readFile :: 'FilePath' -> m 'ByteString' + , _writeFile :: 'FilePath' -> 'ByteString' -> m () } + deriving ('Generic') +@ + + The 'Effect' class requires you to provide a record of methods for your effect. This is done + with an associated data type. You can read about them here + + The class also has two functions: 'liftThrough' and 'mergeContext'. Luckily, because our effect + is simple (and mostly they will be), it's enough to just derive 'Generic' for our type. The + functions are then defined for us. + + It's a convention to name the methods starting with an underscore so we can define the following + helper functions: + +@ +readFile :: 'MonadEffect' Files m => 'FilePath' -> m 'ByteString' +writeFile :: 'MonadEffect' Files m => 'FilePath' -> 'ByteString' -> m () +FilesMethods readFile writeFile = 'effect' +@ + + So how does this work, and what does it even do? Well, we defined how a record of methods looks + for our effect, but how is that record actually constructed? If we wanted to /use/ our methods + where would we get them from? Enter the 'effect' function. It's type signature is + @'MonadEffect' e m => 'EffMethods' e m@. It means that for every monad @m@ which supports the + effect @e@, the 'effect' function gives us a record of the effect's methods. Let's say we want + to read the contents of a file. First we'd use the 'effect' function to get the methods of our + @Files@ effect, then we'd get the @_readFile@ function out of it, and finally we'd use that + function. + +@ +myFunction = do + let methods = 'effect' + let rfFunction = _readFile methods + rfFunction "somefile.txt" + -- or equivalently + _readFile 'effect' "somefile.txt" +@ + + Now since writing @_readFile 'effect'@ gets tedious, we can define new top level helper + functions: + +@ +readFile = _readFile 'effect' +writeFile = _writeFile 'effect' +@ + + The @_readFile@ and @_writeFile@ functions are nothing more than record selectors that get the + appropriate method from our @FilesMethods@ record. With this in mind we can skip them and just + directly pattern match on the @FilesMethods@ constructor like + +@ +FilesMethods readFile writeFile = 'effect' +@ + + Check out the previous part if you want to learn more. +-} +{- $implement + We've only defined the 'syntax' of our effect. How do we actually run those functions? This is + done through the 'implement' function. It lets us construct the implementations at runtime. + + Suppose we have a function like + +@ +myFunc :: 'MonadEffect' Files m => m () +myFunc = do + file <- readFile "file.dat" + newFile <- doSomething file + writeFile "file.dat" newFile +@ + + To use it in our program we need to handle the 'MonadEffect' constraint. This is how we might do + it: + +@ +main :: IO () +main = do + 'implement' (FilesMethods 'B.readFile' 'B.writeFile') myFunc +@ + + Here we implemented our effect using the 'B.readFile' and 'B.writeFile' functions from the + "Data.ByteString" module. Of course we're free to implement them however we want. In a testing + environment we might instead just read/write from a @'Map' 'FilePath' 'ByteString'@ and simulate + a filesystem. + + To make it easier to use our effect, it's a good idea to provide one or more default handlers. + For example, we might define two handlers: + +@ +implementFilesViaIO :: 'MonadIO' m => 'RuntimeImplemented' Files m a -> m a +implementFilesViaMap :: 'Monad' m => 'RuntimeImplemented' Files ('StateT' ('Map' 'FilePath' 'ByteString') m) a -> m a +@ + + This way the users of our effect don't have to implement the handlers themselves, but are still free + to implement more specialized ones. +-} +{- $print + For our next effect we'll do logging. Just a simple printing function that takes anything + with a 'Show' instance and logs it somewhere. + + The signature we want is @print :: ('MonadEffect' Print m, 'Show' a) => a -> m ()@. Now here's + the main issue. The @a@ variable isn't mentioned anywhere in the effect. After all, we don't + want a separate effect for each possible type. We want the @Print@ effect to provide printing + /for all/ types with a 'Show' instance. To this end we'll use the @RankNTypes@ extension and define + our 'Effect' instance like this: + +@ +data Print + +instance 'Effect' Print where + data 'EffMethods' Print m = PrintMethods + { _print :: forall a. Show a => a -> m () } +@ + + Notice we didn't derive 'Generic'. This is because we can't. Despite our effect being simple + (the function's parameter doesn't depend on @m@ and it returns a monadic action), the @forall@ + in there makes it impossible to derive a 'Generic' instance. Unfortunately, this means that we + have to implement the two functions of the 'Effect' class ourselves. Fortunately, it's a very + mechanical procedure (that's why they can usually be automatically derived!). + + The two functions are + +@ +'liftThrough' :: ('MonadTrans' t, 'Monad' m, 'Monad' (t m)) => 'EffMethods' e m -> 'EffMethods' e (t m) +@ + + and + +@ +'mergeContext' :: 'Monad' m => m ('EffMethods' e m) -> 'EffMethods' e m +@ + + [Note] + The 'MonadTrans' part is a slight simplification, but it's an honest one for our current + example. You can read more about the actual definitions and the purpose of these two + functions in the previous part of the tutorial. + + The first function, 'liftThrough', takes a record of methods of the effect @e@ for the monad + @m@, and is expected to return a new record, but this time for the monad @t m@. Two puzzle + pieces make this very easy to do. The first is the fact that the only place where @m@ is mentioned + in our effect is in the result of the @_print@ function. The second piece of the puzzle is the + @'lift' :: ('MonadTrans' t, 'Monad' m) => m a -> (t m) a@ function of the 'MonadTrans' class. So to + construct the new @_print@ method, we just call the old one and 'lift' the result: + +@ +'liftThrough' (PrintMethods pr) = PrintMethods (\\a -> 'lift' (pr a)) +@ + + This will work for as many methods with as many parameters as you want. The implementation will + always look something like + +@ +'liftThough' (MyMethods m1 m2 m3 m4) = MyMethods + (\\a -> 'lift' (m1 a)) + (\\a b c -> 'lift' (m2 a b c)) + (\\a b -> 'lift' (m3 a b)) + ('lift' m4) +@ + + Up next: 'mergeContext'. It says that given the record of methods /inside a monadic context/, + give me just the record, somehow pushing that context inside of it. The implementation is again + very mechanical. + +@ +'mergeContext' pm = PrintMethods + (\\a -> do + PrintMethods p <- pm + p a) +@ + + Essentially, we just pass the parameters through to the old record, but first we must actually + get the old record out of the monadic context. We can do that because each method's result is + a monadic action. Here's how it would look like for a bigger effect: + +@ +'mergeContext' mm = MyMethods + (\\a -> do + MyMethods m _ _ _ <- mm + m a) + (\\a b c -> do + MyMethods _ m _ _ <- mm + m a b c) + (\\a b -> do + MyMethods _ _ m _ <- mm + m a b) + (do + MyMethods _ _ _ m <- mm + m) +@ + + [Note] + Instead of pattern matching, we can use the name of our method as a field selector: + + @ + 'mergeContext' pm = PrintMethods + (\\a -> do + m <- pm + _print m a) + @ + + As you can see, there isn't much to these implementations. Just boilerplate. Also note that + while our @Print@ effect may seem simple, it's actually more complicated than it needs to be. + Instead we could have defined the whole thing like this: + +@ +data Print +instance 'Effect' Print where + data 'EffMethods' Print m = PrintMethods + { _printString :: 'String' -> m () } + deriving ('Generic') + +print :: ('MonadEffect' Print m, 'Show' a) => a -> m () +print = _printString 'effect' . 'show' +@ + + That way we still get a nice polymorhpic function, but the effect itself is monomorphic and + lets us get away with just deriving 'Generic'. + + Next, we'll look at a non-simple effect. One for which the 'liftThrough' method can't be + derived because there isn't just a single valid implementation. +-} +{- $fork + Here's the challenge. There's a 'forkIO' function in base with the following signature + +@ +'forkIO' :: IO () -> IO 'ThreadId' +@ + + We want to generalize this function to work with monads other than 'IO'. Essentially, we want + +@ +fork :: 'MonadEffect' Fork m => m () -> m ('Maybe' 'ThreadId') +@ + + [Note] + The 'Maybe' part is so we don't get tied down to 'IO'. Don't worry about it for now. + + Notice that this isn't a simple effect as the parameter is a monadic action. Anyways, let's try + defining our effect and see where we get stuck: + +@ +data Fork +instance 'Effect' Fork where + data 'EffMethods' Fork m = ForkMethods + { _fork :: m () -> m ('Maybe' 'ThreadId') } + 'mergeContext' mm = ForkMethods + (\\a -> do + ForkMethods m <- mm + m a) + 'liftThrough' (ForkMethods f) = ForkMethods + (\\a -> 'lift' (f a)) +@ + + Simple right? Well, unfortunately it doesn't typecheck. The problem is in the 'liftThrough' + function. Here are the relevant types: + +@ +f :: m () -> m 'ThreadId' +a :: t m () +@ + + The result we need is of type @t m 'ThreadId'@. If we could somehow get a @m 'ThreadId'@ we'd + be fine since just 'lift'ing that does the trick. The problem is, the only way to get a + @m 'ThreadId'@ is by calling @f@ with a @m ()@, and we don't have that. What we do have is + @a :: t m ()@ so it seems that we need a function that's opposite of 'lift'. Something like + @unlift :: t m a -> m a@. + + + Turns out, that's not so simple to do. Imagine you have a function like with a type @a -> m b@. + In this case the @a ->@ part is @t@. If we specialize @unlift@ to that we get + @unlift :: (a -> m b) -> m b@. There's no way to implement that function. To get @m b@ we need + to have an @a@, but none are given to us. + + In any case, even if @unlift@ was possible to implement, it's not like we could use it. The only + thing we know about @t@ is that it has a 'MonadTrans' instance (that's where we get the 'lift' + function from)... Well, not exactly. Remember that note about 'MonadTrans' being a + simplification? The 'Effect' class actually has an additional associated type. It lets us + require a custom constraint for our transformer so we can actually require @t@ to be an instance + of anything we like. + + [Note] + This extra power doesn't come for free, though. Stricter requirements mean that your effect can't + be used in certain situations. What this means exactly is a bit out of the scope of this tutorial, + but here's a quick rundown. + + Handling effects requires monad transformers. Each effect handled will result in at least one + extra transformer on your transformer stack. Those transformers are the types that need to + satisfy the requirements of your effect. Having 'MonadTrans' as a requirement is basically + free since each transformer has a 'MonadTrans' instance, kind of by definition. Anything + extra and things get a bit more complicated. To \"lift\" functions like 'forkIO' into other + transformers, people usually use the 'MonadTransControl' class from the "monad-control" + package. Pretty much all the standard transformers are instances of that class, with one + exception: 'ContT' isn't an instance of 'MonadTransControl'. 'ContT' is a pretty exotic + transformer though. + + What we're going to use here is the 'RunnableTrans' class. This is an alternative to the + 'MonadTransControl' class that's hopefully a bit easier to use. It lets us \"run\" a transformer + if we give it the right state value. It also lets us get the current state value from the context + and it can restore the context from the result of running the transformer. To cut through the + confusion (or perhaps to introduce more of it) here's the code: + +@ +data Fork +instance 'Effect' Fork where + data 'EffMethods' Fork m = ForkMethods + { _fork :: m () -> m ('Maybe' 'ThreadId') } + type 'CanLift' Fork t = 'RunnableTrans' t + 'mergeContext' mm = ForkMethods + (\\a -> do + ForkMethods m <- mm + m a) + 'liftThrough' (ForkMethods f) = ForkMethods + (\\a -> do + st <- 'currentTransState' + 'lift' (f ('void' ('runTransformer' a st))) + ) +@ + + Essentially what we do here is get the current state from the main computation (the one doing + the forking), using that state to run the forked computation, discard both its result /and/ + it's state using the 'void' function, then we finally call the original function and 'lift' the + whole thing. + + [Note] + Since we're discarding the result and the state of the forked computation, and this will + happen for each transformer/effect in the stack, it means that only effects that \"survive\" + are the final 'IO' ones. The state of the original computation does get shared with the + forked one, so that's pretty useful, but if we care about what the forked computation /did/ + with that state, we need to communicate with the original thread manually through some 'IO' + mechanism like 'MVar's. + + What about the effect handlers? How do we write one for our @Fork@ effect? Here's one that + ignores completely what the intended semantics were and just runs the thing sequentially: + +@ +implementForkSequentially :: Monad m => RuntimeImplemented Fork m a -> m a +implementForkSequentially = 'implement' (ForkMethods (\c -> c >> 'return' 'Nothing')) +@ + + But to /really/ fork the computation we have to use the original 'forkIO' function like this: + +@ +implementForkIO :: RuntimeImplemented Fork IO a -> IO a +implementForkIO = 'implement' (ForkMethods ('fmap' 'Just' . 'forkIO')) +@ + + Notice that this forces our monad to IO. This means no other effects can be handled after it. + This is manageable if @Fork@ is the only effect with that condition, but what if there are more + 'IO' based ones? A solution is to provide a @'MonadEffect' Fork IO@ instance directly + +@ +instance 'MonadEffect' Fork IO where + effect = ForkMethods ('fmap' 'Just' . 'liftIO') +@ + + Now we can write @implementForkIO@ like this + +@ +implementForkIO :: IO a -> IO a +implementForkIO = 'id' +@ + + As you can see, the function doesn't do anything, but it does force whatever we give it to be + in the 'IO' monad. This again means that we must handle this effect after all others, but if + there are other effects with the same requirement, they can all be handled at the end. +-} diff --git a/src/Tutorial/Test.hs b/src/Tutorial/Test.hs new file mode 100644 --- /dev/null +++ b/src/Tutorial/Test.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Tutorial.Test where + +import Data.Text as T +import Data.Text.IO as T +import Control.Monad.IO.Class +import Control.Effects.State +import Control.Effects.List +import Control.Concurrent +import Control.Monad.Runnable +import Control.Monad.Trans +import Control.Monad + +addFruit :: (MonadIO m, MonadEffect (State [Text]) m) => m () +addFruit = do + liftIO (T.putStrLn "Name a type of fruit please") + fruit <- liftIO T.getLine + knownFruits <- getState + setState (fruit : knownFruits) + +main1 :: IO () +main1 = implementStateViaStateT @[Text] [] $ do + addFruit + addFruit + addFruit + fruits <- getState @[Text] + liftIO (print fruits) + +main2 :: IO () +main2 = + evaluateAll $ + implementStateViaStateT @[Text] [] $ do + addFruit + addFruit + addFruit + fruits <- getState @[Text] + fruit <- choose fruits + liftIO (print fruit) + +main3 :: IO () +main3 = do + evaluateAll $ + implementStateViaStateT @Int 0 $ do + setState @Int 1 + choose (Prelude.replicate 3 ()) + setState . succ =<< getState @Int + liftIO . print =<< getState @Int + implementStateViaStateT @Int 0 $ + evaluateAll $ do + setState @Int 1 + choose (Prelude.replicate 3 ()) + setState . succ =<< getState @Int + liftIO . print =<< getState @Int + +main4 :: IO () +main4 = do + lst <- evaluateToList $ + implementStateViaStateT @Int 0 $ do + setState @Int 1 + choose (Prelude.replicate 3 ()) + setState . succ =<< getState @Int + getState @Int + print lst + implementStateViaStateT @Int 0 $ do + evaluateAll $ do + setState @Int 1 + choose (Prelude.replicate 3 ()) + setState . succ =<< getState @Int + liftIO . print =<< getState @Int + +data Fork +instance Effect Fork where + data EffMethods Fork m = ForkMethods + { _fork :: m () -> m (Maybe ThreadId) } + type CanLift Fork t = RunnableTrans t + mergeContext mm = ForkMethods + (\a -> do + ForkMethods m <- mm + m a) + liftThrough (ForkMethods f) = ForkMethods + (\a -> do + st <- currentTransState + lift (f (void (runTransformer a st))) + ) + +instance MonadEffect Fork IO where + effect = ForkMethods (fmap Just . forkIO) + +fork :: MonadEffect Fork m => m () -> m (Maybe ThreadId) +fork = _fork effect + +testMethod :: (MonadEffects '[State Int, Fork] m, MonadIO m) => m () +testMethod = do + modifyState @Int (+10) + tid <- void $ fork $ do + liftIO . print =<< getState @Int + liftIO $ threadDelay 2000000 + modifyState @Int (+10) + liftIO . print =<< getState @Int + liftIO $ threadDelay 1000000 + liftIO $ print tid + modifyState @Int (+10) + liftIO . print =<< getState @Int + liftIO $ threadDelay 3000000 + liftIO . print =<< getState @Int + +main5 :: IO () +main5 = implementStateViaStateT @Int 0 testMethod diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} module Main where import Control.Monad.IO.Class @@ -7,13 +9,19 @@ import Control.Effects.State import Control.Effects.Parallel import Control.Effects.Early +import Control.Effects.Async +import Control.Effects.List +import Control.Effects.Yield +import Control.Concurrent hiding (yield) +import System.IO + import Data.Function -- Should infer ex1 = signal True -- Should compile -ex2 :: Throws Bool m => m () +ex2 :: MonadEffect (Throw Bool) m => m () ex2 = throwSignal False ex3 = do @@ -37,7 +45,7 @@ testEarly2 = handleEarly $ earlyReturn 'a' -orderTest :: (Handles Bool m, MonadEffect (State Int) m, MonadIO m) => m () +orderTest :: (MonadEffects '[HandleException Bool, Throw Bool, State Int] m, MonadIO m) => m () orderTest = do setState (1 :: Int) _ :: Either Bool () <- handleToEitherRecursive $ do @@ -59,14 +67,60 @@ main :: IO () main = do orderTest & handleException (\(_ :: Bool) -> return ()) - & handleStateT (0 :: Int) - orderTest & handleStateT (0 :: Int) + & implementStateViaStateT (0 :: Int) + orderTest & implementStateViaStateT (0 :: Int) & handleException (\(_ :: Bool) -> return ()) putStrLn "Starting sequential test" - replicateM_ 8 (handleStateT (0 :: Int) task >>= print) + replicateM_ 8 (implementStateViaStateT (0 :: Int) task >>= print) putStrLn "Sequential test done" putStrLn "Starting parallel test" - handleStateT (0 :: Int) $ do + implementStateViaStateT (0 :: Int) $ do res <- parallelWithSequence (replicate 8 task) mapM_ (liftIO . print) res putStrLn "Parallel test done" + +parallelTest :: + (MonadEffects '[Async, NonDeterminism] m, MonadIO m) => m (AsyncThread m (Int, Char)) +parallelTest = do + n <- choose [1,2,3,4] + async $ do + liftIO $ threadDelay ((5 - n) * 1000000) + l <- choose "ab" + return (n, l) + +mainAsync :: IO () +mainAsync = do + threads <- evaluateToList parallelTest + forM_ threads $ \thread -> + evaluateToList (do + p <- waitAsync thread + liftIO $ print p + ) + +yieldTest :: + (MonadEffects '[Yield Int, Async] m, MonadIO m) => m () +yieldTest = do + yield @Int 5 + t <- async $ do + liftIO $ putStrLn "yielding 6" + yield @Int 6 + liftIO $ putStrLn "yielding 10" + yield @Int 10 + + t2 <- async $ do + liftIO $ putStrLn "yielding 8" + yield @Int 8 + liftIO $ putStrLn "yielding 9" + yield @Int 9 + yield @Int 7 + waitAsync t + waitAsync t2 + return () + +mainYield :: IO () +mainYield = do + hSetBuffering stdout LineBuffering + await <- implementYieldViaMVar @Int yieldTest + traverseYielded_ await $ \res -> do + print res + void getLine