mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-12-12 02:13:15 +03:00
organize
This commit is contained in:
Sandy Maguire
parent
0e349d46fd
commit
0b998cf6f9
135
src/Eff/Combinators.hs
Normal file
135
src/Eff/Combinators.hs
Normal file
@ -0,0 +1,135 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Eff.Combinators where
|
||||
|
||||
import qualified Control.Monad.Trans.Except as E
|
||||
import Control.Monad.Trans.Cont
|
||||
import qualified Control.Monad.Trans.State.Strict as S
|
||||
import Data.OpenUnion
|
||||
import Eff.Type
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Interpret as an effect in terms of another effect in the stack.
|
||||
natural
|
||||
:: Member eff' r
|
||||
=> (eff ~> eff')
|
||||
-> Eff (eff ': r) ~> Eff r
|
||||
natural = naturally id
|
||||
{-# INLINE natural #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Interpret an effect as a monadic action in 'Eff r'.
|
||||
interpret :: (eff ~> Eff r) -> Eff (eff ': r) ~> Eff r
|
||||
interpret f (Freer m) = Freer $ \k -> m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> k x
|
||||
Right y -> runFreer (f y) k
|
||||
{-# INLINE interpret #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'interpret', but with access to intermediate state.
|
||||
interpretS
|
||||
:: (eff ~> S.StateT s (Eff r))
|
||||
-> s
|
||||
-> Eff (eff ': r) ~> Eff r
|
||||
interpretS f s = transform (flip S.evalStateT s) f
|
||||
{-# INLINE interpretS #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Replace the topmost layer of the effect stack with another. This is often
|
||||
-- useful for interpreters which would like to introduce some intermediate
|
||||
-- effects before immediately handling them.
|
||||
replace
|
||||
:: (eff ~> eff')
|
||||
-> Eff (eff ': r) ~> Eff (eff' ': r)
|
||||
replace = naturally weaken
|
||||
{-# INLINE replace #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an effect via the side-effects of a monad transformer.
|
||||
transform
|
||||
:: ( MonadTrans t
|
||||
, MFunctor t
|
||||
, forall m. Monad m => Monad (t m)
|
||||
)
|
||||
=> (forall m. Monad m => t m a -> m b)
|
||||
-- ^ The strategy for getting out of the monad transformer.
|
||||
-> (eff ~> t (Eff r))
|
||||
-> Eff (eff ': r) a
|
||||
-> Eff r b
|
||||
transform lower f (Freer m) = Freer $ \k -> lower $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> lift $ k x
|
||||
Right y -> hoist (runIt k) $ f y
|
||||
{-# INLINE transform #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an effect, potentially short circuiting in its evaluation.
|
||||
shortCircuit
|
||||
:: (eff ~> E.ExceptT e (Eff r))
|
||||
-> Eff (eff ': r) a
|
||||
-> Eff r (Either e a)
|
||||
shortCircuit f = transform E.runExceptT $ \e -> f e
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an effect with an explicit continuation to the final result. If you're
|
||||
-- not sure why you might need this, you probably don't.
|
||||
--
|
||||
-- Note that this method is slow---roughly 10x slower than the other combinators
|
||||
-- available here. If you just need short circuiting, consider using
|
||||
-- 'shortCircuit' instead.
|
||||
relay
|
||||
:: (a -> Eff r b)
|
||||
-> (forall x. eff x -> (x -> Eff r b) -> Eff r b)
|
||||
-> Eff (eff ': r) a
|
||||
-> Eff r b
|
||||
relay pure' bind' (Freer m) = Freer $ \k ->
|
||||
runIt k $ flip runContT pure' $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> lift $ liftEff x
|
||||
Right y -> ContT $ bind' y
|
||||
{-# INLINE relay #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an effect, potentially changing the entire effect stack underneath it.
|
||||
naturally
|
||||
:: Member eff' r'
|
||||
=> (Union r ~> Union r')
|
||||
-> (eff ~> eff')
|
||||
-> Eff (eff ': r) ~> Eff r'
|
||||
naturally z f (Freer m) = Freer $ \k -> m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> k $ z x
|
||||
Right y -> k . inj $ f y
|
||||
{-# INLINE naturally #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Analogous to MTL's 'lift'.
|
||||
raise :: Eff r a -> Eff (u ': r) a
|
||||
raise = hoistEff weaken
|
||||
{-# INLINE raise #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Introduce a new effect directly underneath the top of the stack. This is
|
||||
-- often useful for interpreters which would like to introduce some intermediate
|
||||
-- effects before immediately handling them.
|
||||
--
|
||||
-- Also see 'replace'.
|
||||
introduce :: Eff (eff ': r) a -> Eff (eff ': u ': r) a
|
||||
introduce = hoistEff intro
|
||||
{-# INLINE introduce #-}
|
||||
|
||||
81
src/Eff/Type.hs
Normal file
81
src/Eff/Type.hs
Normal file
@ -0,0 +1,81 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
|
||||
module Eff.Type
|
||||
( module Eff.Type
|
||||
, MFunctor (..)
|
||||
, MonadTrans (..)
|
||||
) where
|
||||
|
||||
import Control.Monad.Morph
|
||||
import Control.Monad.Trans (MonadTrans (..))
|
||||
import Data.Functor.Identity
|
||||
import Data.OpenUnion
|
||||
|
||||
|
||||
type Eff r = Freer (Union r)
|
||||
|
||||
newtype Freer f a = Freer
|
||||
{ runFreer :: forall m. Monad m => (f ~> m) -> m a
|
||||
}
|
||||
|
||||
instance Functor (Freer f) where
|
||||
fmap f (Freer z) = Freer $ \z' -> fmap f $ z z'
|
||||
{-# INLINE fmap #-}
|
||||
|
||||
|
||||
instance Applicative (Freer f) where
|
||||
pure a = Freer $ const $ pure a
|
||||
{-# INLINE pure #-}
|
||||
Freer f <*> Freer a = Freer $ \k -> f k <*> a k
|
||||
{-# INLINE (<*>) #-}
|
||||
|
||||
|
||||
instance Monad (Freer f) where
|
||||
return = pure
|
||||
{-# INLINE return #-}
|
||||
Freer ma >>= f = Freer $ \k -> do
|
||||
z <- ma k
|
||||
runFreer (f z) k
|
||||
{-# INLINE (>>=) #-}
|
||||
|
||||
instance MonadTrans Freer where
|
||||
lift = liftEff
|
||||
|
||||
instance MFunctor Freer where
|
||||
hoist = hoistEff
|
||||
|
||||
hoistEff :: (f ~> g) -> Freer f ~> Freer g
|
||||
hoistEff nat (Freer m) = Freer $ \k -> m $ k . nat
|
||||
{-# INLINE hoistEff #-}
|
||||
|
||||
|
||||
liftEff :: f x -> Freer f x
|
||||
liftEff u = Freer $ \k -> k u
|
||||
{-# INLINE liftEff #-}
|
||||
|
||||
type f ~> g = forall x. f x -> g x
|
||||
infixr 1 ~>
|
||||
|
||||
|
||||
send :: Member eff r => eff a -> Eff r a
|
||||
send t = Freer $ \k -> k $ inj t
|
||||
{-# INLINE send #-}
|
||||
|
||||
|
||||
runM :: Monad m => Freer (Union '[m]) a -> m a
|
||||
runM z = runFreer z extract
|
||||
{-# INLINE runM #-}
|
||||
|
||||
|
||||
run :: Freer (Union '[Identity]) a -> a
|
||||
run = runIdentity . runM
|
||||
{-# INLINE run #-}
|
||||
|
||||
|
||||
runIt :: Monad m => (forall t. f t -> m t) -> Freer f a -> m a
|
||||
runIt k m = runFreer m k
|
||||
160
src/Lib.hs
160
src/Lib.hs
@ -1,98 +1,19 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
|
||||
module Lib where
|
||||
|
||||
import Control.Monad.Morph
|
||||
import Control.Monad.Trans (MonadTrans (..))
|
||||
import Control.Monad.Trans.Cont
|
||||
import qualified Control.Monad.Trans.Except as E
|
||||
import qualified Control.Monad.Trans.State.Strict as S
|
||||
import Data.Functor.Identity
|
||||
import Data.OpenUnion
|
||||
import Data.OpenUnion.Internal
|
||||
|
||||
|
||||
newtype Freer f a = Freer
|
||||
{ runFreer :: forall m. Monad m => (forall t. f t -> m t) -> m a
|
||||
}
|
||||
|
||||
instance MonadTrans Freer where
|
||||
lift = liftEff
|
||||
|
||||
instance MFunctor Freer where
|
||||
hoist = hoistEff
|
||||
|
||||
|
||||
hoistEff :: (f ~> g) -> Freer f ~> Freer g
|
||||
hoistEff nat (Freer m) = Freer $ \k -> m $ k . nat
|
||||
{-# INLINE hoistEff #-}
|
||||
|
||||
|
||||
|
||||
liftEff :: f x -> Freer f x
|
||||
liftEff u = Freer $ \k -> k u
|
||||
{-# INLINE liftEff #-}
|
||||
|
||||
|
||||
instance Functor (Freer f) where
|
||||
fmap f (Freer z) = Freer $ \z' -> fmap f $ z z'
|
||||
{-# INLINE fmap #-}
|
||||
|
||||
|
||||
instance Applicative (Freer f) where
|
||||
pure a = Freer $ const $ pure a
|
||||
{-# INLINE pure #-}
|
||||
Freer f <*> Freer a = Freer $ \k -> f k <*> a k
|
||||
{-# INLINE (<*>) #-}
|
||||
|
||||
|
||||
instance Monad (Freer f) where
|
||||
return = pure
|
||||
{-# INLINE return #-}
|
||||
Freer ma >>= f = Freer $ \k -> do
|
||||
z <- ma k
|
||||
runFreer (f z) k
|
||||
{-# INLINE (>>=) #-}
|
||||
|
||||
|
||||
type Eff r = Freer (Union r)
|
||||
|
||||
|
||||
send :: Member eff r => eff a -> Eff r a
|
||||
send t = Freer $ \k -> k $ inj t
|
||||
{-# INLINE send #-}
|
||||
|
||||
|
||||
unsafeSend :: Word -> eff a -> Eff r a
|
||||
unsafeSend w t = Freer $ \k -> k $ unsafeInj w t
|
||||
{-# INLINE unsafeSend #-}
|
||||
|
||||
|
||||
runM :: Monad m => Freer (Union '[m]) a -> m a
|
||||
runM z = runFreer z extract
|
||||
{-# INLINE runM #-}
|
||||
|
||||
|
||||
run :: Freer (Union '[Identity]) a -> a
|
||||
run = runIdentity . runM
|
||||
{-# INLINE run #-}
|
||||
import Eff.Combinators
|
||||
import Eff.Type
|
||||
|
||||
|
||||
data State s a where
|
||||
@ -117,36 +38,6 @@ foom = do
|
||||
put "nice!"
|
||||
get @String
|
||||
|
||||
type f ~> g = forall x. f x -> g x
|
||||
infixr 1 ~>
|
||||
|
||||
|
||||
interpret :: (eff ~> Eff r) -> Eff (eff ': r) ~> Eff r
|
||||
interpret f (Freer m) = Freer $ \k -> m $ \u -> do
|
||||
case decomp u of
|
||||
Left x -> k x
|
||||
Right y -> runFreer (f y) k
|
||||
{-# INLINE interpret #-}
|
||||
|
||||
|
||||
runIt :: Monad m => (forall t. f t -> m t) -> Freer f a -> m a
|
||||
runIt k m = runFreer m k
|
||||
|
||||
|
||||
relay
|
||||
:: (a -> Eff r b)
|
||||
-> (forall x. eff x -> (x -> Eff r b) -> Eff r b)
|
||||
-> Eff (eff ': r) a
|
||||
-> Eff r b
|
||||
relay pure' bind' (Freer m) = Freer $ \k -> do
|
||||
runIt k $ flip runContT pure' $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> lift $ liftEff x
|
||||
Right y -> ContT $ bind' y
|
||||
{-# INLINE relay #-}
|
||||
|
||||
|
||||
|
||||
|
||||
runTeletype :: forall r a. Member IO r => Eff (State String ': r) a -> Eff r a
|
||||
runTeletype = interpret bind
|
||||
@ -160,51 +51,6 @@ runTeletype = interpret bind
|
||||
-- main = runM (runState "fuck" foom) >>= print
|
||||
|
||||
|
||||
raise :: Eff r a -> Eff (u ': r) a
|
||||
raise = hoistEff weaken
|
||||
{-# INLINE raise #-}
|
||||
|
||||
|
||||
introduce :: Eff (eff ': r) a -> Eff (eff ': u ': r) a
|
||||
introduce = hoistEff intro
|
||||
{-# INLINE introduce #-}
|
||||
|
||||
|
||||
interpretS
|
||||
:: (eff ~> S.StateT s (Eff r))
|
||||
-> s
|
||||
-> Eff (eff ': r) ~> Eff r
|
||||
interpretS f s = transform (flip S.evalStateT s) f
|
||||
{-# INLINE interpretS #-}
|
||||
|
||||
|
||||
transform
|
||||
:: ( MonadTrans t
|
||||
, MFunctor t
|
||||
, forall m. Monad m => Monad (t m)
|
||||
)
|
||||
=> (forall m. Monad m => t m a -> m b)
|
||||
-> (eff ~> t (Eff r))
|
||||
-> Eff (eff ': r) a -> Eff r b
|
||||
transform lower f (Freer m) = Freer $ \k -> lower $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> lift $ k x
|
||||
Right y -> hoist (runIt k) $ f y
|
||||
{-# INLINE transform #-}
|
||||
|
||||
lowerFreer :: Freer (Freer m) a -> Freer m a
|
||||
lowerFreer m = runFreer m id
|
||||
|
||||
|
||||
natural
|
||||
:: Member eff' r
|
||||
=> (eff ~> eff') -> Eff (eff ': r) a -> Eff r a
|
||||
natural f (Freer m) = Freer $ \k -> m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> k x
|
||||
Right y -> k $ inj $ f y
|
||||
|
||||
|
||||
runState :: forall s r a. s -> Eff (State s ': r) a -> Eff r a
|
||||
runState = interpretS $ \case
|
||||
Get -> S.get
|
||||
@ -221,7 +67,7 @@ throwError = send . Error
|
||||
|
||||
|
||||
runError :: Eff (Error e ': r) a -> Eff r (Either e a)
|
||||
runError = transform E.runExceptT $ \(Error e) -> E.throwE e
|
||||
runError = shortCircuit $ \(Error e) -> E.throwE e
|
||||
|
||||
|
||||
runErrorRelay :: Eff (Error e ': r) a -> Eff r (Either e a)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user