mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-12-03 21:13:10 +03:00
%s/Semantic/Sem/g
This commit is contained in:
Keagan McClelland
parent
6d8ac644a8
commit
1ed6049dca
@ -1,10 +1,9 @@
|
||||
module Polysemy
|
||||
( -- * Core Types
|
||||
Semantic ()
|
||||
, Sem
|
||||
Sem ()
|
||||
, Member
|
||||
|
||||
-- * Running Semantic
|
||||
-- * Running Sem
|
||||
, run
|
||||
, runM
|
||||
|
||||
@ -31,17 +30,17 @@ module Polysemy
|
||||
-- type/ of the actions. Writing a line returns a '()', but reading one
|
||||
-- returns 'String'.
|
||||
--
|
||||
-- By enabling @-XTemplateHaskell@, we can use the 'makeSemantic' function
|
||||
-- By enabling @-XTemplateHaskell@, we can use the 'makeSem' function
|
||||
-- to generate smart constructors for the actions. These smart constructors
|
||||
-- can be invoked directly inside of the 'Semantic' monad.
|
||||
-- can be invoked directly inside of the 'Sem' monad.
|
||||
--
|
||||
-- >>> makeSemantic ''Console
|
||||
-- >>> makeSem ''Console
|
||||
--
|
||||
-- results in the following definitions:
|
||||
--
|
||||
-- @
|
||||
-- writeLine :: 'Member' Console r => String -> 'Semantic' r ()
|
||||
-- readLine :: 'Member' Console r => 'Semantic' r String
|
||||
-- writeLine :: 'Member' Console r => String -> 'Sem' r ()
|
||||
-- readLine :: 'Member' Console r => 'Sem' r String
|
||||
-- @
|
||||
--
|
||||
-- Effects which don't make use of the @m@ parameter are known as
|
||||
@ -49,7 +48,7 @@ module Polysemy
|
||||
|
||||
-- ** Higher-Order Effects
|
||||
-- | Every effect has access to the @m@ parameter, which corresponds to the
|
||||
-- 'Semantic' monad it's used in. Using this parameter, we're capable of
|
||||
-- 'Sem' monad it's used in. Using this parameter, we're capable of
|
||||
-- writing effects which themselves contain subcomputations.
|
||||
--
|
||||
-- For example, the definition of 'Polysemy.Error.Error' is
|
||||
@ -63,16 +62,16 @@ module Polysemy
|
||||
-- where 'Polysemy.Error.Catch' is an action that can run an exception
|
||||
-- handler if its first argument calls 'Polysemy.Error.throw'.
|
||||
--
|
||||
-- >>> makeSemantic ''Error
|
||||
-- >>> makeSem ''Error
|
||||
--
|
||||
-- @
|
||||
-- 'Polysemy.Error.throw' :: 'Member' ('Polysemy.Error.Error' e) r => e -> 'Semantic' r a
|
||||
-- 'Polysemy.Error.catch' :: 'Member' ('Polysemy.Error.Error' e) r => 'Semantic' r a -> (e -> 'Semantic' r a) -> 'Semantic' r a
|
||||
-- 'Polysemy.Error.throw' :: 'Member' ('Polysemy.Error.Error' e) r => e -> 'Sem' r a
|
||||
-- 'Polysemy.Error.catch' :: 'Member' ('Polysemy.Error.Error' e) r => 'Sem' r a -> (e -> 'Sem' r a) -> 'Sem' r a
|
||||
-- @
|
||||
--
|
||||
-- As you see, in the smart constructors, the @m@ parameter has become @'Semantic' r@.
|
||||
, makeSemantic
|
||||
, makeSemantic_
|
||||
-- As you see, in the smart constructors, the @m@ parameter has become @'Sem' r@.
|
||||
, makeSem
|
||||
, makeSem_
|
||||
|
||||
-- * Combinators for Interpreting First-Order Effects
|
||||
, interpret
|
||||
|
||||
@ -27,7 +27,7 @@ data Error e m a where
|
||||
Throw :: e -> Error e m a
|
||||
Catch :: ∀ e m a. m a -> (e -> m a) -> Error e m a
|
||||
|
||||
makeSemantic ''Error
|
||||
makeSem ''Error
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -35,15 +35,15 @@ makeSemantic ''Error
|
||||
-- 'Control.Monad.Trans.Except.ExceptT'.
|
||||
runError
|
||||
:: Typeable e
|
||||
=> Semantic (Error e ': r) a
|
||||
-> Semantic r (Either e a)
|
||||
runError (Semantic m) = Semantic $ \k -> E.runExceptT $ m $ \u ->
|
||||
=> Sem (Error e ': r) a
|
||||
-> Sem r (Either e a)
|
||||
runError (Sem m) = Sem $ \k -> E.runExceptT $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> E.ExceptT $ k $
|
||||
weave (Right ()) (either (pure . Left) runError_b) x
|
||||
Right (Yo (Throw e) _ _ _) -> E.throwE e
|
||||
Right (Yo (Catch try handle) s d y) ->
|
||||
E.ExceptT $ usingSemantic k $ do
|
||||
E.ExceptT $ usingSem k $ do
|
||||
ma <- runError_b $ d $ try <$ s
|
||||
case ma of
|
||||
Right a -> pure . Right $ y a
|
||||
@ -56,8 +56,8 @@ runError (Semantic m) = Semantic $ \k -> E.runExceptT $ m $ \u ->
|
||||
|
||||
runError_b
|
||||
:: Typeable e
|
||||
=> Semantic (Error e ': r) a
|
||||
-> Semantic r (Either e a)
|
||||
=> Sem (Error e ': r) a
|
||||
-> Sem r (Either e a)
|
||||
runError_b = runError
|
||||
{-# NOINLINE runError_b #-}
|
||||
|
||||
@ -78,12 +78,12 @@ runErrorInIO
|
||||
:: ( Typeable e
|
||||
, Member (Lift IO) r
|
||||
)
|
||||
=> (∀ x. Semantic r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Semantic' action down to 'IO'. This is
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is
|
||||
-- likely some combination of 'runM' and other interpters composed via
|
||||
-- '.@'.
|
||||
-> Semantic (Error e ': r) a
|
||||
-> Semantic r (Either e a)
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r (Either e a)
|
||||
runErrorInIO lower
|
||||
= sendM
|
||||
. fmap (first unwrapExc)
|
||||
@ -96,9 +96,9 @@ runErrorAsExc
|
||||
:: forall e r a. ( Typeable e
|
||||
, Member (Lift IO) r
|
||||
)
|
||||
=> (∀ x. Semantic r x -> IO x)
|
||||
-> Semantic (Error e ': r) a
|
||||
-> Semantic r a
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r a
|
||||
runErrorAsExc lower = interpretH $ \case
|
||||
Throw e -> sendM $ X.throwIO $ WrappedExc e
|
||||
Catch try handle -> do
|
||||
@ -115,9 +115,9 @@ runErrorAsExc_b
|
||||
:: ( Typeable e
|
||||
, Member (Lift IO) r
|
||||
)
|
||||
=> (∀ x. Semantic r x -> IO x)
|
||||
-> Semantic (Error e ': r) a
|
||||
-> Semantic r a
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r a
|
||||
runErrorAsExc_b = runErrorAsExc
|
||||
{-# NOINLINE runErrorAsExc_b #-}
|
||||
|
||||
|
||||
@ -16,9 +16,9 @@ import Polysemy.Internal.Fixpoint
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Fixpoint' effect purely.
|
||||
runFixpoint
|
||||
:: (∀ x. Semantic r x -> x)
|
||||
-> Semantic (Fixpoint ': r) a
|
||||
-> Semantic r a
|
||||
:: (∀ x. Sem r x -> x)
|
||||
-> Sem (Fixpoint ': r) a
|
||||
-> Sem r a
|
||||
runFixpoint lower = interpretH $ \case
|
||||
Fixpoint mf -> do
|
||||
c <- bindT mf
|
||||
@ -31,9 +31,9 @@ runFixpointM
|
||||
:: ( MonadFix m
|
||||
, Member (Lift m) r
|
||||
)
|
||||
=> (∀ x. Semantic r x -> m x)
|
||||
-> Semantic (Fixpoint ': r) a
|
||||
-> Semantic r a
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
-> Sem (Fixpoint ': r) a
|
||||
-> Sem r a
|
||||
runFixpointM lower = interpretH $ \case
|
||||
Fixpoint mf -> do
|
||||
c <- bindT mf
|
||||
|
||||
@ -25,12 +25,12 @@ import Polysemy.State
|
||||
data Input i m a where
|
||||
Input :: Input i m i
|
||||
|
||||
makeSemantic ''Input
|
||||
makeSem ''Input
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Input' effect by always giving back the same value.
|
||||
runConstInput :: i -> Semantic (Input i ': r) a -> Semantic r a
|
||||
runConstInput :: i -> Sem (Input i ': r) a -> Sem r a
|
||||
runConstInput c = interpret \case
|
||||
Input -> pure c
|
||||
{-# INLINE runConstInput #-}
|
||||
@ -42,8 +42,8 @@ runConstInput c = interpret \case
|
||||
runListInput
|
||||
:: Typeable i
|
||||
=> [i]
|
||||
-> Semantic (Input (Maybe i) ': r) a
|
||||
-> Semantic r a
|
||||
-> Sem (Input (Maybe i) ': r) a
|
||||
-> Sem r a
|
||||
runListInput is = fmap snd . runState is . reinterpret \case
|
||||
Input -> do
|
||||
s <- gets uncons
|
||||
@ -54,7 +54,7 @@ runListInput is = fmap snd . runState is . reinterpret \case
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Runs an 'Input' effect by evaluating a monadic action for each request.
|
||||
runMonadicInput :: Semantic r i -> Semantic (Input i ': r) a -> Semantic r a
|
||||
runMonadicInput :: Sem r i -> Sem (Input i ': r) a -> Sem r a
|
||||
runMonadicInput m = interpret \case
|
||||
Input -> m
|
||||
{-# INLINE runMonadicInput #-}
|
||||
|
||||
@ -4,8 +4,7 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Polysemy.Internal
|
||||
( Semantic (..)
|
||||
, Sem
|
||||
( Sem (..)
|
||||
, Member
|
||||
, send
|
||||
, sendM
|
||||
@ -13,9 +12,9 @@ module Polysemy.Internal
|
||||
, runM
|
||||
, raise
|
||||
, Lift ()
|
||||
, usingSemantic
|
||||
, liftSemantic
|
||||
, hoistSemantic
|
||||
, usingSem
|
||||
, liftSem
|
||||
, hoistSem
|
||||
, (.@)
|
||||
, (.@@)
|
||||
) where
|
||||
@ -32,12 +31,12 @@ import Polysemy.Internal.Union
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The 'Semantic' monad handles computations of arbitrary extensible effects.
|
||||
-- A value of type @Semantic r@ describes a program with the capabilities of
|
||||
-- | The 'Sem' monad handles computations of arbitrary extensible effects.
|
||||
-- A value of type @Sem r@ describes a program with the capabilities of
|
||||
-- @r@. For best results, @r@ should always be kept polymorphic, but you can
|
||||
-- add capabilities via the 'Member' constraint.
|
||||
--
|
||||
-- The value of the 'Semantic' monad is that it allows you to write programs
|
||||
-- The value of the 'Sem' monad is that it allows you to write programs
|
||||
-- against a set of effects without a predefined meaning, and provide that
|
||||
-- meaning later. For example, unlike with mtl, you can decide to interpret an
|
||||
-- 'Polysemy.Error.Error' effect tradtionally as an 'Either', or instead
|
||||
@ -49,14 +48,14 @@ import Polysemy.Internal.Union
|
||||
--
|
||||
-- The effect stack @r@ can contain arbitrary other monads inside of it. These
|
||||
-- monads are lifted into effects via the 'Lift' effect. Monadic values can be
|
||||
-- lifted into a 'Semantic' via 'sendM'.
|
||||
-- lifted into a 'Sem' via 'sendM'.
|
||||
--
|
||||
-- A 'Semantic' can be interpreted as a pure value (via 'run') or as any
|
||||
-- A 'Sem' can be interpreted as a pure value (via 'run') or as any
|
||||
-- traditional 'Monad' (via 'runM'). Each effect @E@ comes equipped with some
|
||||
-- interpreters of the form:
|
||||
--
|
||||
-- @
|
||||
-- runE :: 'Semantic' (E ': r) a -> 'Semantic' r a
|
||||
-- runE :: 'Sem' (E ': r) a -> 'Sem' r a
|
||||
-- @
|
||||
--
|
||||
-- which is responsible for removing the effect @E@ from the effect stack. It
|
||||
@ -64,7 +63,7 @@ import Polysemy.Internal.Union
|
||||
-- monomorphic representation of the @r@ parameter.
|
||||
--
|
||||
-- After all of your effects are handled, you'll be left with either
|
||||
-- a @'Semantic' '[] a@ or a @'Semantic' ('Lift' m) a@ value, which can be
|
||||
-- a @'Sem' '[] a@ or a @'Sem' ('Lift' m) a@ value, which can be
|
||||
-- consumed respectively by 'run' and 'runM'.
|
||||
--
|
||||
-- ==== Examples
|
||||
@ -72,14 +71,14 @@ import Polysemy.Internal.Union
|
||||
-- As an example of keeping @r@ polymorphic, we can consider the type
|
||||
--
|
||||
-- @
|
||||
-- 'Member' ('Polysemy.State' String) r => 'Semantic' r ()
|
||||
-- 'Member' ('Polysemy.State' String) r => 'Sem' r ()
|
||||
-- @
|
||||
--
|
||||
-- to be a program with access to
|
||||
--
|
||||
-- @
|
||||
-- 'Polysemy.State.get' :: 'Semantic' r String
|
||||
-- 'Polysemy.State.put' :: String -> 'Semantic' r ()
|
||||
-- 'Polysemy.State.get' :: 'Sem' r String
|
||||
-- 'Polysemy.State.put' :: String -> 'Sem' r ()
|
||||
-- @
|
||||
--
|
||||
-- methods.
|
||||
@ -93,25 +92,25 @@ import Polysemy.Internal.Union
|
||||
-- constraint on @r@, we gain access to the
|
||||
--
|
||||
-- @
|
||||
-- 'Polysemy.Error.throw' :: Bool -> 'Semantic' r a
|
||||
-- 'Polysemy.Error.catch' :: 'Semantic' r a -> (Bool -> 'Semantic' r a) -> 'Semantic' r a
|
||||
-- 'Polysemy.Error.throw' :: Bool -> 'Sem' r a
|
||||
-- 'Polysemy.Error.catch' :: 'Sem' r a -> (Bool -> 'Sem' r a) -> 'Sem' r a
|
||||
-- @
|
||||
--
|
||||
-- functions as well.
|
||||
--
|
||||
-- In this sense, a @'Member' ('Polysemy.State.State' s) r@ constraint is
|
||||
-- analogous to mtl's @'Control.Monad.State.Class.MonadState' s m@ and should
|
||||
-- be thought of as such. However, /unlike/ mtl, a 'Semantic' monad may have
|
||||
-- be thought of as such. However, /unlike/ mtl, a 'Sem' monad may have
|
||||
-- an arbitrary number of the same effect.
|
||||
--
|
||||
-- For example, we can write a 'Semantic' program which can output either
|
||||
-- For example, we can write a 'Sem' program which can output either
|
||||
-- 'Int's or 'Bool's:
|
||||
--
|
||||
-- @
|
||||
-- foo :: ( 'Member' ('Polysemy.Output.Output' Int) r
|
||||
-- , 'Member' ('Polysemy.Output.Output' Bool) r
|
||||
-- )
|
||||
-- => 'Semantic' r ()
|
||||
-- => 'Sem' r ()
|
||||
-- foo = do
|
||||
-- 'Polysemy.Output.output' @Int 5
|
||||
-- 'Polysemy.Output.output' True
|
||||
@ -119,53 +118,49 @@ import Polysemy.Internal.Union
|
||||
--
|
||||
-- Notice that we must use @-XTypeApplications@ to specify that we'd like to
|
||||
-- use the ('Polysemy.Output.Output' 'Int') effect.
|
||||
newtype Semantic r a = Semantic
|
||||
{ runSemantic
|
||||
newtype Sem r a = Sem
|
||||
{ runSem
|
||||
:: ∀ m
|
||||
. Monad m
|
||||
=> (∀ x. Union r (Semantic r) x -> m x)
|
||||
=> (∀ x. Union r (Sem r) x -> m x)
|
||||
-> m a
|
||||
}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Convenience synonym for 'Semantic'
|
||||
type Sem r a = Semantic r a
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'runSemantic' but flipped for better ergonomics sometimes.
|
||||
usingSemantic
|
||||
-- | Like 'runSem' but flipped for better ergonomics sometimes.
|
||||
usingSem
|
||||
:: Monad m
|
||||
=> (∀ x. Union r (Semantic r) x -> m x)
|
||||
-> Semantic r a
|
||||
=> (∀ x. Union r (Sem r) x -> m x)
|
||||
-> Sem r a
|
||||
-> m a
|
||||
usingSemantic k m = runSemantic m k
|
||||
{-# INLINE usingSemantic #-}
|
||||
usingSem k m = runSem m k
|
||||
{-# INLINE usingSem #-}
|
||||
|
||||
|
||||
instance Functor (Semantic f) where
|
||||
fmap f (Semantic m) = Semantic $ \k -> fmap f $ m k
|
||||
instance Functor (Sem f) where
|
||||
fmap f (Sem m) = Sem $ \k -> fmap f $ m k
|
||||
{-# INLINE fmap #-}
|
||||
|
||||
|
||||
instance Applicative (Semantic f) where
|
||||
pure a = Semantic $ const $ pure a
|
||||
instance Applicative (Sem f) where
|
||||
pure a = Sem $ const $ pure a
|
||||
{-# INLINE pure #-}
|
||||
|
||||
Semantic f <*> Semantic a = Semantic $ \k -> f k <*> a k
|
||||
Sem f <*> Sem a = Sem $ \k -> f k <*> a k
|
||||
{-# INLINE (<*>) #-}
|
||||
|
||||
|
||||
instance Monad (Semantic f) where
|
||||
instance Monad (Sem f) where
|
||||
return = pure
|
||||
{-# INLINE return #-}
|
||||
|
||||
Semantic ma >>= f = Semantic $ \k -> do
|
||||
Sem ma >>= f = Sem $ \k -> do
|
||||
z <- ma k
|
||||
runSemantic (f z) k
|
||||
runSem (f z) k
|
||||
{-# INLINE (>>=) #-}
|
||||
|
||||
|
||||
instance (Member NonDet r) => Alternative (Semantic r) where
|
||||
instance (Member NonDet r) => Alternative (Sem r) where
|
||||
empty = send Empty
|
||||
a <|> b = do
|
||||
send (Choose id) >>= \case
|
||||
@ -173,67 +168,67 @@ instance (Member NonDet r) => Alternative (Semantic r) where
|
||||
True -> b
|
||||
|
||||
|
||||
instance (Member (Lift IO) r) => MonadIO (Semantic r) where
|
||||
instance (Member (Lift IO) r) => MonadIO (Sem r) where
|
||||
liftIO = sendM
|
||||
{-# INLINE liftIO #-}
|
||||
|
||||
instance Member Fixpoint r => MonadFix (Semantic r) where
|
||||
instance Member Fixpoint r => MonadFix (Sem r) where
|
||||
mfix f = send $ Fixpoint f
|
||||
|
||||
|
||||
liftSemantic :: Union r (Semantic r) a -> Semantic r a
|
||||
liftSemantic u = Semantic $ \k -> k u
|
||||
{-# INLINE liftSemantic #-}
|
||||
liftSem :: Union r (Sem r) a -> Sem r a
|
||||
liftSem u = Sem $ \k -> k u
|
||||
{-# INLINE liftSem #-}
|
||||
|
||||
|
||||
hoistSemantic
|
||||
:: (∀ x. Union r (Semantic r) x -> Union r' (Semantic r') x)
|
||||
-> Semantic r a
|
||||
-> Semantic r' a
|
||||
hoistSemantic nat (Semantic m) = Semantic $ \k -> m $ \u -> k $ nat u
|
||||
{-# INLINE hoistSemantic #-}
|
||||
hoistSem
|
||||
:: (∀ x. Union r (Sem r) x -> Union r' (Sem r') x)
|
||||
-> Sem r a
|
||||
-> Sem r' a
|
||||
hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u
|
||||
{-# INLINE hoistSem #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Introduce an effect into 'Semantic'. Analogous to
|
||||
-- | Introduce an effect into 'Sem'. Analogous to
|
||||
-- 'Control.Monad.Class.Trans.lift' in the mtl ecosystem
|
||||
raise :: ∀ e r a. Semantic r a -> Semantic (e ': r) a
|
||||
raise = hoistSemantic $ hoist raise_b . weaken
|
||||
raise :: ∀ e r a. Sem r a -> Sem (e ': r) a
|
||||
raise = hoistSem $ hoist raise_b . weaken
|
||||
{-# INLINE raise #-}
|
||||
|
||||
|
||||
raise_b :: Semantic r a -> Semantic (e ': r) a
|
||||
raise_b :: Sem r a -> Sem (e ': r) a
|
||||
raise_b = raise
|
||||
{-# NOINLINE raise_b #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lift an effect into a 'Semantic'. This is used primarily via
|
||||
-- 'Polysemy.makeSemantic' to implement smart constructors.
|
||||
send :: Member e r => e (Semantic r) a -> Semantic r a
|
||||
send = liftSemantic . inj
|
||||
-- | Lift an effect into a 'Sem'. This is used primarily via
|
||||
-- 'Polysemy.makeSem' to implement smart constructors.
|
||||
send :: Member e r => e (Sem r) a -> Sem r a
|
||||
send = liftSem . inj
|
||||
{-# INLINE[3] send #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lift a monadic action @m@ into 'Semantic'.
|
||||
sendM :: Member (Lift m) r => m a -> Semantic r a
|
||||
-- | Lift a monadic action @m@ into 'Sem'.
|
||||
sendM :: Member (Lift m) r => m a -> Sem r a
|
||||
sendM = send . Lift
|
||||
{-# INLINE sendM #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Semantic' containing no effects as a pure value.
|
||||
run :: Semantic '[] a -> a
|
||||
run (Semantic m) = runIdentity $ m absurdU
|
||||
-- | Run a 'Sem' containing no effects as a pure value.
|
||||
run :: Sem '[] a -> a
|
||||
run (Sem m) = runIdentity $ m absurdU
|
||||
{-# INLINE run #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lower a 'Semantic' containing only a single lifted 'Monad' into that
|
||||
-- | Lower a 'Sem' containing only a single lifted 'Monad' into that
|
||||
-- monad.
|
||||
runM :: Monad m => Semantic '[Lift m] a -> m a
|
||||
runM (Semantic m) = m $ \z ->
|
||||
runM :: Monad m => Sem '[Lift m] a -> m a
|
||||
runM (Sem m) = m $ \z ->
|
||||
case extract z of
|
||||
Yo e s _ f -> do
|
||||
a <- unLift e
|
||||
@ -267,12 +262,12 @@ runM (Semantic m) = m $ \z ->
|
||||
-- precedence errors.
|
||||
(.@)
|
||||
:: Monad m
|
||||
=> (∀ x. Semantic r x -> m x)
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
-- ^ The lowering function, likely 'runM'.
|
||||
-> (∀ y. (∀ x. Semantic r x -> m x)
|
||||
-> Semantic (e ': r) y
|
||||
-> Semantic r y)
|
||||
-> Semantic (e ': r) z
|
||||
-> (∀ y. (∀ x. Sem r x -> m x)
|
||||
-> Sem (e ': r) y
|
||||
-> Sem r y)
|
||||
-> Sem (e ': r) z
|
||||
-> m z
|
||||
f .@ g = f . g f
|
||||
infixl 9 .@
|
||||
@ -283,12 +278,12 @@ infixl 9 .@
|
||||
-- 'Polysemy.Error.runErrorInIO'.
|
||||
(.@@)
|
||||
:: Monad m
|
||||
=> (∀ x. Semantic r x -> m x)
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
-- ^ The lowering function, likely 'runM'.
|
||||
-> (∀ y. (∀ x. Semantic r x -> m x)
|
||||
-> Semantic (e ': r) y
|
||||
-> Semantic r (f y))
|
||||
-> Semantic (e ': r) z
|
||||
-> (∀ y. (∀ x. Sem r x -> m x)
|
||||
-> Sem (e ': r) y
|
||||
-> Sem r (f y))
|
||||
-> Sem (e ': r) z
|
||||
-> m (f z)
|
||||
f .@@ g = f . g f
|
||||
infixl 9 .@@
|
||||
|
||||
@ -41,11 +41,11 @@ swap ~(a, b) = (b, a)
|
||||
-- transforming it into other effects inside of 'r'.
|
||||
interpret
|
||||
:: FirstOrder e "interpret"
|
||||
=> (∀ x m. e m x -> Semantic r x)
|
||||
=> (∀ x m. e m x -> Sem r x)
|
||||
-- ^ A natural transformation from the handled effect to other effects
|
||||
-- already in 'Semantic'.
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r a
|
||||
-- already in 'Sem'.
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r a
|
||||
-- TODO(sandy): could probably give a `coerce` impl for `runTactics` here
|
||||
interpret f = interpretH $ \(e :: e m x) -> liftT @m $ f e
|
||||
|
||||
@ -58,12 +58,12 @@ interpret f = interpretH $ \(e :: e m x) -> liftT @m $ f e
|
||||
interpretH
|
||||
:: (∀ x m . e m x -> Tactical e m r x)
|
||||
-- ^ A natural transformation from the handled effect to other effects
|
||||
-- already in 'Semantic'.
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r a
|
||||
interpretH f (Semantic m) = m $ \u ->
|
||||
-- already in 'Sem'.
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r a
|
||||
interpretH f (Sem m) = m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> liftSemantic $ hoist (interpretH_b f) x
|
||||
Left x -> liftSem $ hoist (interpretH_b f) x
|
||||
Right (Yo e s d y) -> do
|
||||
a <- runTactics s (raise . interpretH_b f . d) (f e)
|
||||
pure $ y a
|
||||
@ -74,11 +74,11 @@ interpretH f (Semantic m) = m $ \u ->
|
||||
-- 'stateful' for a more user-friendly variety of this function.
|
||||
interpretInStateT
|
||||
:: Typeable s
|
||||
=> (∀ x m. e m x -> S.StateT s (Semantic r) x)
|
||||
=> (∀ x m. e m x -> S.StateT s (Sem r) x)
|
||||
-> s
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r (s, a)
|
||||
interpretInStateT f s (Semantic m) = Semantic $ \k ->
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r (s, a)
|
||||
interpretInStateT f s (Sem m) = Sem $ \k ->
|
||||
fmap swap $ flip S.runStateT s $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> S.StateT $ \s' ->
|
||||
@ -86,7 +86,7 @@ interpretInStateT f s (Semantic m) = Semantic $ \k ->
|
||||
. weave (s', ()) (uncurry $ interpretInStateT_b f)
|
||||
$ x
|
||||
Right (Yo e z _ y) ->
|
||||
fmap (y . (<$ z)) $ S.mapStateT (usingSemantic k) $ f e
|
||||
fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e
|
||||
{-# INLINE interpretInStateT #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -94,11 +94,11 @@ interpretInStateT f s (Semantic m) = Semantic $ \k ->
|
||||
-- 'stateful' for a more user-friendly variety of this function.
|
||||
interpretInLazyStateT
|
||||
:: Typeable s
|
||||
=> (∀ x m. e m x -> LS.StateT s (Semantic r) x)
|
||||
=> (∀ x m. e m x -> LS.StateT s (Sem r) x)
|
||||
-> s
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r (s, a)
|
||||
interpretInLazyStateT f s (Semantic m) = Semantic $ \k ->
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r (s, a)
|
||||
interpretInLazyStateT f s (Sem m) = Sem $ \k ->
|
||||
fmap swap $ flip LS.runStateT s $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> LS.StateT $ \s' ->
|
||||
@ -106,17 +106,17 @@ interpretInLazyStateT f s (Semantic m) = Semantic $ \k ->
|
||||
. weave (s', ()) (uncurry $ interpretInLazyStateT_b f)
|
||||
$ x
|
||||
Right (Yo e z _ y) ->
|
||||
fmap (y . (<$ z)) $ LS.mapStateT (usingSemantic k) $ f e
|
||||
fmap (y . (<$ z)) $ LS.mapStateT (usingSem k) $ f e
|
||||
{-# INLINE interpretInLazyStateT #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'interpret', but with access to an intermediate state @s@.
|
||||
stateful
|
||||
:: Typeable s
|
||||
=> (∀ x m. e m x -> s -> Semantic r (s, x))
|
||||
=> (∀ x m. e m x -> s -> Sem r (s, x))
|
||||
-> s
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r (s, a)
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r (s, a)
|
||||
stateful f = interpretInStateT $ \e -> S.StateT $ fmap swap . f e
|
||||
{-# INLINE[3] stateful #-}
|
||||
|
||||
@ -125,10 +125,10 @@ stateful f = interpretInStateT $ \e -> S.StateT $ fmap swap . f e
|
||||
-- | Like 'interpret', but with access to an intermediate state @s@.
|
||||
lazilyStateful
|
||||
:: Typeable s
|
||||
=> (∀ x m. e m x -> s -> Semantic r (s, x))
|
||||
=> (∀ x m. e m x -> s -> Sem r (s, x))
|
||||
-> s
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r (s, a)
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r (s, a)
|
||||
lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e
|
||||
{-# INLINE[3] lazilyStateful #-}
|
||||
|
||||
@ -140,13 +140,13 @@ lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e
|
||||
reinterpretH
|
||||
:: (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)
|
||||
-- ^ A natural transformation from the handled effect to the new effect.
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': r) a
|
||||
reinterpretH f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': r) a
|
||||
reinterpretH f (Sem m) = Sem $ \k -> m $ \u ->
|
||||
case decompCoerce u of
|
||||
Left x -> k $ hoist (reinterpretH_b f) $ x
|
||||
Right (Yo e s d y) -> do
|
||||
a <- usingSemantic k $ runTactics s (raise . reinterpretH_b f . d) $ f e
|
||||
a <- usingSem k $ runTactics s (raise . reinterpretH_b f . d) $ f e
|
||||
pure $ y a
|
||||
{-# INLINE[3] reinterpretH #-}
|
||||
-- TODO(sandy): Make this fuse in with 'stateful' directly.
|
||||
@ -159,10 +159,10 @@ reinterpretH f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-- the 'Polysemy.State.State' effect and immediately run it.
|
||||
reinterpret
|
||||
:: FirstOrder e1 "reinterpret"
|
||||
=> (∀ m x. e1 m x -> Semantic (e2 ': r) x)
|
||||
=> (∀ m x. e1 m x -> Sem (e2 ': r) x)
|
||||
-- ^ A natural transformation from the handled effect to the new effect.
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': r) a
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': r) a
|
||||
reinterpret f = reinterpretH $ \(e :: e m x) -> liftT @m $ f e
|
||||
{-# INLINE[3] reinterpret #-}
|
||||
-- TODO(sandy): Make this fuse in with 'stateful' directly.
|
||||
@ -175,13 +175,13 @@ reinterpret f = reinterpretH $ \(e :: e m x) -> liftT @m $ f e
|
||||
reinterpret2H
|
||||
:: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)
|
||||
-- ^ A natural transformation from the handled effect to the new effects.
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': e3 ': r) a
|
||||
reinterpret2H f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': e3 ': r) a
|
||||
reinterpret2H f (Sem m) = Sem $ \k -> m $ \u ->
|
||||
case decompCoerce u of
|
||||
Left x -> k $ weaken $ hoist (reinterpret2H_b f) $ x
|
||||
Right (Yo e s d y) -> do
|
||||
a <- usingSemantic k $ runTactics s (raise . reinterpret2H_b f . d) $ f e
|
||||
a <- usingSem k $ runTactics s (raise . reinterpret2H_b f . d) $ f e
|
||||
pure $ y a
|
||||
{-# INLINE[3] reinterpret2H #-}
|
||||
|
||||
@ -190,10 +190,10 @@ reinterpret2H f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-- | Like 'reinterpret', but introduces /two/ intermediary effects.
|
||||
reinterpret2
|
||||
:: FirstOrder e1 "reinterpret2"
|
||||
=> (∀ m x. e1 m x -> Semantic (e2 ': e3 ': r) x)
|
||||
=> (∀ m x. e1 m x -> Sem (e2 ': e3 ': r) x)
|
||||
-- ^ A natural transformation from the handled effect to the new effects.
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': e3 ': r) a
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': e3 ': r) a
|
||||
reinterpret2 f = reinterpret2H $ \(e :: e m x) -> liftT @m $ f e
|
||||
{-# INLINE[3] reinterpret2 #-}
|
||||
|
||||
@ -205,13 +205,13 @@ reinterpret2 f = reinterpret2H $ \(e :: e m x) -> liftT @m $ f e
|
||||
reinterpret3H
|
||||
:: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)
|
||||
-- ^ A natural transformation from the handled effect to the new effects.
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': e3 ': e4 ': r) a
|
||||
reinterpret3H f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': e3 ': e4 ': r) a
|
||||
reinterpret3H f (Sem m) = Sem $ \k -> m $ \u ->
|
||||
case decompCoerce u of
|
||||
Left x -> k . weaken . weaken . hoist (reinterpret3H_b f) $ x
|
||||
Right (Yo e s d y) -> do
|
||||
a <- usingSemantic k $ runTactics s (raise . reinterpret3H_b f . d) $ f e
|
||||
a <- usingSem k $ runTactics s (raise . reinterpret3H_b f . d) $ f e
|
||||
pure $ y a
|
||||
{-# INLINE[3] reinterpret3H #-}
|
||||
|
||||
@ -220,10 +220,10 @@ reinterpret3H f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-- | Like 'reinterpret', but introduces /three/ intermediary effects.
|
||||
reinterpret3
|
||||
:: FirstOrder e1 "reinterpret2"
|
||||
=> (∀ m x. e1 m x -> Semantic (e2 ': e3 ': e4 ': r) x)
|
||||
=> (∀ m x. e1 m x -> Sem (e2 ': e3 ': e4 ': r) x)
|
||||
-- ^ A natural transformation from the handled effect to the new effects.
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': e3 ': e4 ': r) a
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': e3 ': e4 ': r) a
|
||||
reinterpret3 f = reinterpret3H $ \(e :: e m x) -> liftT @m $ f e
|
||||
{-# INLINE[3] reinterpret3 #-}
|
||||
|
||||
@ -236,12 +236,12 @@ intercept
|
||||
:: ( Member e r
|
||||
, FirstOrder e "intercept"
|
||||
)
|
||||
=> (∀ x m. e m x -> Semantic r x)
|
||||
=> (∀ x m. e m x -> Sem r x)
|
||||
-- ^ A natural transformation from the handled effect to other effects
|
||||
-- already in 'Semantic'.
|
||||
-> Semantic r a
|
||||
-- already in 'Sem'.
|
||||
-> Sem r a
|
||||
-- ^ Unlike 'interpret', 'intercept' does not consume any effects.
|
||||
-> Semantic r a
|
||||
-> Sem r a
|
||||
intercept f = interceptH $ \(e :: e m x) -> liftT @m $ f e
|
||||
{-# INLINE intercept #-}
|
||||
|
||||
@ -254,14 +254,14 @@ interceptH
|
||||
:: Member e r
|
||||
=> (∀ x m. e m x -> Tactical e m r x)
|
||||
-- ^ A natural transformation from the handled effect to other effects
|
||||
-- already in 'Semantic'.
|
||||
-> Semantic r a
|
||||
-- already in 'Sem'.
|
||||
-> Sem r a
|
||||
-- ^ Unlike 'interpretH', 'interceptH' does not consume any effects.
|
||||
-> Semantic r a
|
||||
interceptH f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-> Sem r a
|
||||
interceptH f (Sem m) = Sem $ \k -> m $ \u ->
|
||||
case prj u of
|
||||
Just (Yo e s d y) ->
|
||||
usingSemantic k $ fmap y $ runTactics s (raise . d) $ f e
|
||||
usingSem k $ fmap y $ runTactics s (raise . d) $ f e
|
||||
Nothing -> k u
|
||||
{-# INLINE interceptH #-}
|
||||
|
||||
@ -270,52 +270,52 @@ interceptH f (Semantic m) = Semantic $ \k -> m $ \u ->
|
||||
-- Loop breakers
|
||||
interpretH_b
|
||||
:: (∀ x m . e m x -> Tactical e m r x)
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r a
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r a
|
||||
interpretH_b = interpretH
|
||||
{-# NOINLINE interpretH_b #-}
|
||||
|
||||
|
||||
interpretInStateT_b
|
||||
:: Typeable s
|
||||
=> (∀ x m. e m x -> S.StateT s (Semantic r) x)
|
||||
=> (∀ x m. e m x -> S.StateT s (Sem r) x)
|
||||
-> s
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r (s, a)
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r (s, a)
|
||||
interpretInStateT_b = interpretInStateT
|
||||
{-# NOINLINE interpretInStateT_b #-}
|
||||
|
||||
|
||||
interpretInLazyStateT_b
|
||||
:: Typeable s
|
||||
=> (∀ x m. e m x -> LS.StateT s (Semantic r) x)
|
||||
=> (∀ x m. e m x -> LS.StateT s (Sem r) x)
|
||||
-> s
|
||||
-> Semantic (e ': r) a
|
||||
-> Semantic r (s, a)
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r (s, a)
|
||||
interpretInLazyStateT_b = interpretInLazyStateT
|
||||
{-# NOINLINE interpretInLazyStateT_b #-}
|
||||
|
||||
|
||||
reinterpretH_b
|
||||
:: (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': r) a
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': r) a
|
||||
reinterpretH_b = reinterpretH
|
||||
{-# NOINLINE reinterpretH_b #-}
|
||||
|
||||
|
||||
reinterpret2H_b
|
||||
:: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': e3 ': r) a
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': e3 ': r) a
|
||||
reinterpret2H_b = reinterpret2H
|
||||
{-# NOINLINE reinterpret2H_b #-}
|
||||
|
||||
|
||||
reinterpret3H_b
|
||||
:: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)
|
||||
-> Semantic (e1 ': r) a
|
||||
-> Semantic (e2 ': e3 ': e4 ': r) a
|
||||
-> Sem (e1 ': r) a
|
||||
-> Sem (e2 ': e3 ': e4 ': r) a
|
||||
reinterpret3H_b = reinterpret3H
|
||||
{-# NOINLINE reinterpret3H_b #-}
|
||||
|
||||
|
||||
@ -17,7 +17,7 @@ type Typeable1 f = (∀ y. Typeable y => Typeable (f y) :: Constraint)
|
||||
-- An effect @e@ is a type @e m a@, where the other types are given by:
|
||||
--
|
||||
-- * The @m@ type variable corresponds to a monad, which will eventually be
|
||||
-- instantiated at 'Polysemy.Semantic'---meaning it is capable of encoding
|
||||
-- instantiated at 'Polysemy.Sem'---meaning it is capable of encoding
|
||||
-- arbitrary other effects.
|
||||
--
|
||||
-- * The @a@ type is handled automatically and uninteresting.
|
||||
|
||||
@ -4,19 +4,19 @@ module Polysemy.Internal.Lift where
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | An effect which allows a regular 'Monad' @m@ into the 'Polysemy.Semantic'
|
||||
-- ecosystem. Monadic actions in @m@ can be lifted into 'Polysemy.Semantic' via
|
||||
-- | An effect which allows a regular 'Monad' @m@ into the 'Polysemy.Sem'
|
||||
-- ecosystem. Monadic actions in @m@ can be lifted into 'Polysemy.Sem' via
|
||||
-- 'Polysemy.sendM'.
|
||||
--
|
||||
-- For example, you can use this effect to lift 'IO' actions directly into
|
||||
-- 'Polysemy.Semantic':
|
||||
-- 'Polysemy.Sem':
|
||||
--
|
||||
-- @
|
||||
-- 'Polysemy.sendM' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Lift' IO) r => 'Polysemy.Semantic' r ()
|
||||
-- 'Polysemy.sendM' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Lift' IO) r => 'Polysemy.Sem' r ()
|
||||
-- @
|
||||
--
|
||||
-- That being said, you lose out on a significant amount of the benefits of
|
||||
-- 'Polysemy.Semantic' by using 'sendM' directly in application code; doing so
|
||||
-- 'Polysemy.Sem' by using 'sendM' directly in application code; doing so
|
||||
-- will tie your application code directly to the underlying monad, and prevent
|
||||
-- you from interpreting it differently. For best results, only use 'Lift' in
|
||||
-- your effect interpreters.
|
||||
|
||||
@ -15,22 +15,22 @@ the module documentation for "Polysemy", we can write the following:
|
||||
data FileSystem m a where
|
||||
ReadFile :: 'FilePath' -> FileSystem 'String'
|
||||
WriteFile :: 'FilePath' -> 'String' -> FileSystem ()
|
||||
'makeSemantic' ''FileSystem
|
||||
'makeSem' ''FileSystem
|
||||
@
|
||||
|
||||
This will automatically generate the following functions:
|
||||
|
||||
@
|
||||
readFile :: 'Member' FileSystem r => 'FilePath' -> 'Semantic' r 'String'
|
||||
readFile :: 'Member' FileSystem r => 'FilePath' -> 'Sem' r 'String'
|
||||
readFile a = 'send' (ReadFile a)
|
||||
|
||||
writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Semantic' r ()
|
||||
writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Sem' r ()
|
||||
writeFile a b = 'send' (WriteFile a b)
|
||||
@
|
||||
-}
|
||||
module Polysemy.Internal.TH.Effect
|
||||
( makeSemantic
|
||||
, makeSemantic_
|
||||
( makeSem
|
||||
, makeSem_
|
||||
)
|
||||
where
|
||||
|
||||
@ -39,17 +39,17 @@ import Data.Char (toLower)
|
||||
import Data.List
|
||||
import Generics.SYB
|
||||
import Language.Haskell.TH
|
||||
import Polysemy.Internal (send, Member, Semantic)
|
||||
import Polysemy.Internal (send, Member, Sem)
|
||||
import Polysemy.Internal.CustomErrors (DefiningModule)
|
||||
|
||||
|
||||
-- | If @T@ is a GADT representing an effect algebra, as described in the module
|
||||
-- documentation for "Polysemy", @$('makeSemantic' ''T)@ automatically
|
||||
-- documentation for "Polysemy", @$('makeSem' ''T)@ automatically
|
||||
-- generates a smart constructor for every data constructor of @T@.
|
||||
makeSemantic :: Name -> Q [Dec]
|
||||
makeSemantic = genFreer True
|
||||
makeSem :: Name -> Q [Dec]
|
||||
makeSem = genFreer True
|
||||
|
||||
-- | Like 'makeSemantic', but does not provide type signatures. This can be used
|
||||
-- | Like 'makeSem', but does not provide type signatures. This can be used
|
||||
-- to attach Haddock comments to individual arguments for each generated
|
||||
-- function.
|
||||
--
|
||||
@ -57,25 +57,25 @@ makeSemantic = genFreer True
|
||||
-- data Lang m a where
|
||||
-- Output :: String -> Lang ()
|
||||
--
|
||||
-- makeSemantic_ ''Lang
|
||||
-- makeSem_ ''Lang
|
||||
--
|
||||
-- -- | Output a string.
|
||||
-- output :: Member Lang r
|
||||
-- => String -- ^ String to output.
|
||||
-- -> Semantic r () -- ^ No result.
|
||||
-- -> Sem r () -- ^ No result.
|
||||
-- @
|
||||
--
|
||||
-- Note that 'makeEffect_' must be used /before/ the explicit type signatures.
|
||||
makeSemantic_ :: Name -> Q [Dec]
|
||||
makeSemantic_ = genFreer False
|
||||
makeSem_ :: Name -> Q [Dec]
|
||||
makeSem_ = genFreer False
|
||||
|
||||
-- | Generates declarations and possibly signatures for functions to lift GADT
|
||||
-- constructors into 'Semantic' actions.
|
||||
-- constructors into 'Sem' actions.
|
||||
genFreer :: Bool -> Name -> Q [Dec]
|
||||
genFreer makeSigs tcName = do
|
||||
-- The signatures for the generated definitions require FlexibleContexts.
|
||||
isExtEnabled FlexibleContexts
|
||||
>>= flip unless (fail "makeSemantic requires FlexibleContexts to be enabled")
|
||||
>>= flip unless (fail "makeSem requires FlexibleContexts to be enabled")
|
||||
hasTyFams <- isExtEnabled TypeFamilies
|
||||
|
||||
reify tcName >>= \case
|
||||
@ -93,7 +93,7 @@ genFreer makeSigs tcName = do
|
||||
| hasTyFams
|
||||
] ++ sigs ++ decs
|
||||
|
||||
_ -> fail "makeSemantic expects a type constructor"
|
||||
_ -> fail "makeSem expects a type constructor"
|
||||
|
||||
-- | Given the name of a GADT constructor, return the name of the corresponding
|
||||
-- lifted function.
|
||||
@ -132,7 +132,7 @@ tyVarBndrKind (PlainTV _) = Nothing
|
||||
tyVarBndrKind (KindedTV _ k) = Just k
|
||||
|
||||
-- | Generates a function type from the corresponding GADT type constructor
|
||||
-- @x :: Member (Effect e) r => a -> b -> c -> Semantic r r@.
|
||||
-- @x :: Member (Effect e) r => a -> b -> c -> Sem r r@.
|
||||
genType :: Con -> Q (Type, Maybe Name, Maybe Type)
|
||||
genType (ForallC tyVarBindings conCtx con) = do
|
||||
(t, mn, _) <- genType con
|
||||
@ -149,9 +149,9 @@ genType (GadtC _ tArgs' (eff `AppT` m `AppT` tRet)) = do
|
||||
let
|
||||
tArgs = fmap snd tArgs'
|
||||
memberConstraint = ConT ''Member `AppT` eff `AppT` VarT r
|
||||
resultType = ConT ''Semantic `AppT` VarT r `AppT` tRet
|
||||
resultType = ConT ''Sem `AppT` VarT r `AppT` tRet
|
||||
|
||||
replaceMType t | t == m = ConT ''Semantic `AppT` VarT r
|
||||
replaceMType t | t == m = ConT ''Sem `AppT` VarT r
|
||||
| otherwise = t
|
||||
ts = everywhere (mkT replaceMType) tArgs
|
||||
tn = case tRet of
|
||||
@ -180,7 +180,7 @@ simplifyBndr _ (KindedTV tv StarT) = PlainTV tv
|
||||
simplifyBndr _ bndr = bndr
|
||||
|
||||
-- | Generates a type signature of the form
|
||||
-- @x :: Member (Effect e) r => a -> b -> c -> Semantic r r@.
|
||||
-- @x :: Member (Effect e) r => a -> b -> c -> Sem r r@.
|
||||
genSig :: Con -> Q Dec
|
||||
genSig con = do
|
||||
let
|
||||
|
||||
@ -23,7 +23,7 @@ import Language.Haskell.TH
|
||||
--
|
||||
-- @
|
||||
-- 'inlineRecursiveCalls' [d|
|
||||
-- 'Polysemy.Reader.runReader' :: i -> 'Polysemy.Semantic' ('Polysemy.Reader.Reader' i ': r) a -> 'Polysemy.Semantic' r a
|
||||
-- 'Polysemy.Reader.runReader' :: i -> 'Polysemy.Sem' ('Polysemy.Reader.Reader' i ': r) a -> 'Polysemy.Sem' r a
|
||||
-- 'Polysemy.Reader.runReader' i = 'Polysemy.interpretH' $ \\case
|
||||
-- 'Polysemy.Reader.Ask' -> 'Polysemy.pureT' i
|
||||
-- 'Polysemy.Reader.Local' f m -> do
|
||||
|
||||
@ -49,9 +49,9 @@ import Polysemy.Internal.Union
|
||||
-- where
|
||||
--
|
||||
-- @
|
||||
-- alloc' :: 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f a1)
|
||||
-- dealloc' :: f a1 -> 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f ())
|
||||
-- use' :: f a1 -> 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f x)
|
||||
-- alloc' :: 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f a1)
|
||||
-- dealloc' :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f ())
|
||||
-- use' :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f x)
|
||||
-- @
|
||||
--
|
||||
-- The @f@ type here is existential and corresponds to "whatever
|
||||
@ -70,20 +70,20 @@ import Polysemy.Internal.Union
|
||||
-- Power users may explicitly use 'getInitialStateT' and 'bindT' to construct
|
||||
-- whatever data flow they'd like; although this is usually necessary.
|
||||
type Tactical e m r x = ∀ f. (Functor f, Typeable1 f)
|
||||
=> Semantic (WithTactics e f m r) (f x)
|
||||
=> Sem (WithTactics e f m r) (f x)
|
||||
|
||||
type WithTactics e f m r = Tactics f m (e ': r) ': r
|
||||
|
||||
data Tactics f n r m a where
|
||||
GetInitialState :: Tactics f n r m (f ())
|
||||
HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Semantic r (f b))
|
||||
HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Get the stateful environment of the world at the moment the effect @e@ is
|
||||
-- to be run. Prefer 'pureT', 'runT' or 'bindT' instead of using this function
|
||||
-- directly.
|
||||
getInitialStateT :: forall f m r e. Semantic (WithTactics e f m r) (f ())
|
||||
getInitialStateT :: forall f m r e. Sem (WithTactics e f m r) (f ())
|
||||
getInitialStateT = send @(Tactics _ m (e ': r)) GetInitialState
|
||||
|
||||
|
||||
@ -103,8 +103,8 @@ runT
|
||||
:: m a
|
||||
-- ^ The monadic action to lift. This is usually a parameter in your
|
||||
-- effect.
|
||||
-> Semantic (WithTactics e f m r)
|
||||
(Semantic (e ': r) (f a))
|
||||
-> Sem (WithTactics e f m r)
|
||||
(Sem (e ': r) (f a))
|
||||
runT na = do
|
||||
istate <- getInitialStateT
|
||||
na' <- bindT (const na)
|
||||
@ -123,8 +123,8 @@ bindT
|
||||
--
|
||||
-- Continuations lifted via 'bindT' will run in the same environment
|
||||
-- which produced the 'a'.
|
||||
-> Semantic (WithTactics e f m r)
|
||||
(f a -> Semantic (e ': r) (f b))
|
||||
-> Sem (WithTactics e f m r)
|
||||
(f a -> Sem (e ': r) (f b))
|
||||
bindT f = send $ HoistInterpretation f
|
||||
{-# INLINE bindT #-}
|
||||
|
||||
@ -137,8 +137,8 @@ liftT
|
||||
. ( Functor f
|
||||
, Typeable1 f
|
||||
)
|
||||
=> Semantic r a
|
||||
-> Semantic (WithTactics e f m r) (f a)
|
||||
=> Sem r a
|
||||
-> Sem (WithTactics e f m r) (f a)
|
||||
liftT m = do
|
||||
a <- raise m
|
||||
pureT a
|
||||
@ -150,12 +150,12 @@ liftT m = do
|
||||
runTactics
|
||||
:: Functor f
|
||||
=> f ()
|
||||
-> (∀ x. f (m x) -> Semantic r2 (f x))
|
||||
-> Semantic (Tactics f m r2 ': r) a
|
||||
-> Semantic r a
|
||||
runTactics s d (Semantic m) = m $ \u ->
|
||||
-> (∀ x. f (m x) -> Sem r2 (f x))
|
||||
-> Sem (Tactics f m r2 ': r) a
|
||||
-> Sem r a
|
||||
runTactics s d (Sem m) = m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> liftSemantic $ hoist (runTactics_b s d) x
|
||||
Left x -> liftSem $ hoist (runTactics_b s d) x
|
||||
Right (Yo GetInitialState s' _ y) ->
|
||||
pure $ y $ s <$ s'
|
||||
Right (Yo (HoistInterpretation na) s' _ y) -> do
|
||||
@ -166,9 +166,9 @@ runTactics s d (Semantic m) = m $ \u ->
|
||||
runTactics_b
|
||||
:: Functor f
|
||||
=> f ()
|
||||
-> (∀ x. f (m x) -> Semantic r2 (f x))
|
||||
-> Semantic (Tactics f m r2 ': r) a
|
||||
-> Semantic r a
|
||||
-> (∀ x. f (m x) -> Sem r2 (f x))
|
||||
-> Sem (Tactics f m r2 ': r) a
|
||||
-> Sem r a
|
||||
runTactics_b = runTactics
|
||||
{-# NOINLINE runTactics_b #-}
|
||||
|
||||
|
||||
@ -54,8 +54,8 @@ instance Monad (NonDetC m) where
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'NonDet' effect in terms of some underlying 'Alternative' @f@.
|
||||
runNonDet :: Alternative f => Semantic (NonDet ': r) a -> Semantic r (f a)
|
||||
runNonDet (Semantic m) = Semantic $ \k -> runNonDetC $ m $ \u ->
|
||||
runNonDet :: Alternative f => Sem (NonDet ': r) a -> Sem r (f a)
|
||||
runNonDet (Sem m) = Sem $ \k -> runNonDetC $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> NonDetC $ \cons nil -> do
|
||||
z <- k $ weave [()] (fmap concat . traverse runNonDet) x
|
||||
|
||||
@ -23,7 +23,7 @@ import Polysemy.State
|
||||
data Output o m a where
|
||||
Output :: o -> Output o m ()
|
||||
|
||||
makeSemantic ''Output
|
||||
makeSem ''Output
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -32,8 +32,8 @@ runFoldMapOutput
|
||||
:: forall o m r a
|
||||
. (Typeable m, Monoid m)
|
||||
=> (o -> m)
|
||||
-> Semantic (Output o ': r) a
|
||||
-> Semantic r (m, a)
|
||||
-> Sem (Output o ': r) a
|
||||
-> Sem r (m, a)
|
||||
runFoldMapOutput f = runState mempty . reinterpret \case
|
||||
Output o -> modify (<> f o)
|
||||
{-# INLINE runFoldMapOutput #-}
|
||||
@ -41,7 +41,7 @@ runFoldMapOutput f = runState mempty . reinterpret \case
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Ouput' effect by ignoring it.
|
||||
runIgnoringOutput :: Semantic (Output o ': r) a -> Semantic r a
|
||||
runIgnoringOutput :: Sem (Output o ': r) a -> Sem r a
|
||||
runIgnoringOutput = interpret \case
|
||||
Output _ -> pure ()
|
||||
{-# INLINE runIgnoringOutput #-}
|
||||
|
||||
@ -24,7 +24,7 @@ data Random m a where
|
||||
Random :: R.Random x => Random m x
|
||||
RandomR :: R.Random x => (x, x) -> Random m x
|
||||
|
||||
makeSemantic ''Random
|
||||
makeSem ''Random
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -35,8 +35,8 @@ runRandom
|
||||
, R.RandomGen q
|
||||
)
|
||||
=> q
|
||||
-> Semantic (Random ': r) a
|
||||
-> Semantic r (q, a)
|
||||
-> Sem (Random ': r) a
|
||||
-> Sem r (q, a)
|
||||
runRandom q = runState q . reinterpret \case
|
||||
Random -> do
|
||||
~(a, q') <- gets @q R.random
|
||||
@ -51,7 +51,7 @@ runRandom q = runState q . reinterpret \case
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Random' effect by using the 'IO' random generator.
|
||||
runRandomIO :: Member (Lift IO) r => Semantic (Random ': r) a -> Semantic r a
|
||||
runRandomIO :: Member (Lift IO) r => Sem (Random ': r) a -> Sem r a
|
||||
runRandomIO m = do
|
||||
q <- sendM R.newStdGen
|
||||
snd <$> runRandom q m
|
||||
|
||||
@ -24,17 +24,17 @@ data Reader i m a where
|
||||
Ask :: Reader i m i
|
||||
Local :: (i -> i) -> m a -> Reader i m a
|
||||
|
||||
makeSemantic ''Reader
|
||||
makeSem ''Reader
|
||||
|
||||
|
||||
asks :: Member (Reader i) r => (i -> j) -> Semantic r j
|
||||
asks :: Member (Reader i) r => (i -> j) -> Sem r j
|
||||
asks f = f <$> ask
|
||||
{-# INLINABLE asks #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Reader' effect with a constant value.
|
||||
runReader :: i -> Semantic (Reader i ': r) a -> Semantic r a
|
||||
runReader :: i -> Sem (Reader i ': r) a -> Sem r a
|
||||
runReader i = interpretH $ \case
|
||||
Ask -> pureT i
|
||||
Local f m -> do
|
||||
@ -42,14 +42,14 @@ runReader i = interpretH $ \case
|
||||
raise $ runReader_b (f i) mm
|
||||
{-# INLINE runReader #-}
|
||||
|
||||
runReader_b :: i -> Semantic (Reader i ': r) a -> Semantic r a
|
||||
runReader_b :: i -> Sem (Reader i ': r) a -> Sem r a
|
||||
runReader_b = runReader
|
||||
{-# NOINLINE runReader_b #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Transform an 'Input' effect into a 'Reader' effect.
|
||||
runInputAsReader :: Semantic (Input i ': r) a -> Semantic (Reader i ': r) a
|
||||
runInputAsReader :: Sem (Input i ': r) a -> Sem (Reader i ': r) a
|
||||
runInputAsReader = reinterpret $ \case
|
||||
Input -> ask
|
||||
{-# INLINE runInputAsReader #-}
|
||||
|
||||
@ -30,7 +30,7 @@ data Resource m a where
|
||||
-- ^ Action which uses the resource.
|
||||
-> Resource m b
|
||||
|
||||
makeSemantic ''Resource
|
||||
makeSem ''Resource
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -38,19 +38,19 @@ makeSemantic ''Resource
|
||||
runResource
|
||||
:: forall r a
|
||||
. Member (Lift IO) r
|
||||
=> (∀ x. Semantic r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Semantic' action down to 'IO'. This is
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is
|
||||
-- likely some combination of 'runM' and other interpters composed via
|
||||
-- '.@'.
|
||||
-> Semantic (Resource ': r) a
|
||||
-> Semantic r a
|
||||
-> Sem (Resource ': r) a
|
||||
-> Sem r a
|
||||
runResource finish = interpretH $ \case
|
||||
Bracket alloc dealloc use -> do
|
||||
a <- runT alloc
|
||||
d <- bindT dealloc
|
||||
u <- bindT use
|
||||
|
||||
let runIt :: Semantic (Resource ': r) x -> IO x
|
||||
let runIt :: Sem (Resource ': r) x -> IO x
|
||||
runIt = finish .@ runResource
|
||||
|
||||
sendM $ X.bracket (runIt a) (runIt . d) (runIt . u)
|
||||
|
||||
@ -31,15 +31,15 @@ data State s m a where
|
||||
Get :: State s m s
|
||||
Put :: s -> State s m ()
|
||||
|
||||
makeSemantic ''State
|
||||
makeSem ''State
|
||||
|
||||
|
||||
gets :: Member (State s) r => (s -> a) -> Semantic r a
|
||||
gets :: Member (State s) r => (s -> a) -> Sem r a
|
||||
gets f = fmap f get
|
||||
{-# INLINABLE gets #-}
|
||||
|
||||
|
||||
modify :: Member (State s) r => (s -> s) -> Semantic r ()
|
||||
modify :: Member (State s) r => (s -> s) -> Sem r ()
|
||||
modify f = do
|
||||
s <- get
|
||||
put $ f s
|
||||
@ -48,7 +48,7 @@ modify f = do
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'State' effect with local state.
|
||||
runState :: Typeable s => s -> Semantic (State s ': r) a -> Semantic r (s, a)
|
||||
runState :: Typeable s => s -> Sem (State s ': r) a -> Sem r (s, a)
|
||||
runState = stateful $ \case
|
||||
Get -> \s -> pure (s, s)
|
||||
Put s -> const $ pure (s, ())
|
||||
@ -57,7 +57,7 @@ runState = stateful $ \case
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'State' effect with local state, lazily.
|
||||
runLazyState :: Typeable s => s -> Semantic (State s ': r) a -> Semantic r (s, a)
|
||||
runLazyState :: Typeable s => s -> Sem (State s ': r) a -> Sem r (s, a)
|
||||
runLazyState = lazilyStateful $ \case
|
||||
Get -> \s -> pure (s, s)
|
||||
Put s -> const $ pure (s, ())
|
||||
@ -65,12 +65,12 @@ runLazyState = lazilyStateful $ \case
|
||||
|
||||
|
||||
{-# RULES "runState/reinterpret"
|
||||
forall s e (f :: forall m x. e m x -> Semantic (State s ': r) x).
|
||||
forall s e (f :: forall m x. e m x -> Sem (State s ': r) x).
|
||||
runState s (reinterpret f e) = stateful (\x s' -> runState s' $ f x) s e
|
||||
#-}
|
||||
|
||||
{-# RULES "runLazyState/reinterpret"
|
||||
forall s e (f :: forall m x. e m x -> Semantic (State s ': r) x).
|
||||
forall s e (f :: forall m x. e m x -> Sem (State s ': r) x).
|
||||
runLazyState s (reinterpret f e) = lazilyStateful (\x s' -> runLazyState s' $ f x) s e
|
||||
#-}
|
||||
|
||||
|
||||
@ -22,12 +22,12 @@ import Polysemy.Output
|
||||
data Trace m a where
|
||||
Trace :: String -> Trace m ()
|
||||
|
||||
makeSemantic ''Trace
|
||||
makeSem ''Trace
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Trace' effect by printing the messages to stdout.
|
||||
runTraceIO :: Member (Lift IO) r => Semantic (Trace ': r) a -> Semantic r a
|
||||
runTraceIO :: Member (Lift IO) r => Sem (Trace ': r) a -> Sem r a
|
||||
runTraceIO = interpret $ \case
|
||||
Trace m -> sendM $ putStrLn m
|
||||
{-# INLINE runTraceIO #-}
|
||||
@ -35,7 +35,7 @@ runTraceIO = interpret $ \case
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Trace' effect by ignoring all of its messages.
|
||||
runIgnoringTrace :: Member (Lift IO) r => Semantic (Trace ': r) a -> Semantic r a
|
||||
runIgnoringTrace :: Member (Lift IO) r => Sem (Trace ': r) a -> Sem r a
|
||||
runIgnoringTrace = interpret $ \case
|
||||
Trace _ -> pure ()
|
||||
{-# INLINE runIgnoringTrace #-}
|
||||
@ -43,7 +43,7 @@ runIgnoringTrace = interpret $ \case
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Transform a 'Trace' effect into a 'Output' 'String' effect.
|
||||
runTraceAsOutput :: Semantic (Trace ': r) a -> Semantic (Output String ': r) a
|
||||
runTraceAsOutput :: Sem (Trace ': r) a -> Sem (Output String ': r) a
|
||||
runTraceAsOutput = reinterpret $ \case
|
||||
Trace m -> output m
|
||||
{-# INLINE runTraceAsOutput #-}
|
||||
|
||||
@ -27,12 +27,12 @@ data Writer o m a where
|
||||
Listen :: ∀ o m a. m a -> Writer o m (o, a)
|
||||
Censor :: (o -> o) -> m a -> Writer o m a
|
||||
|
||||
makeSemantic ''Writer
|
||||
makeSem ''Writer
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Transform an 'Output' effect into a 'Writer' effect.
|
||||
runOutputAsWriter :: Semantic (Output o ': r) a -> Semantic (Writer o ': r) a
|
||||
runOutputAsWriter :: Sem (Output o ': r) a -> Sem (Writer o ': r) a
|
||||
runOutputAsWriter = reinterpret \case
|
||||
Output o -> tell o
|
||||
{-# INLINE runOutputAsWriter #-}
|
||||
@ -43,8 +43,8 @@ runOutputAsWriter = reinterpret \case
|
||||
-- (but without the nasty space leak!)
|
||||
runWriter
|
||||
:: (Monoid o, Typeable o)
|
||||
=> Semantic (Writer o ': r) a
|
||||
-> Semantic r (o, a)
|
||||
=> Sem (Writer o ': r) a
|
||||
-> Sem r (o, a)
|
||||
runWriter = runState mempty . reinterpretH \case
|
||||
Tell o -> do
|
||||
modify (<> o) >>= pureT
|
||||
|
||||
Loading…
Reference in New Issue
Block a user