polysemy-research/polysemy
1
1
Fork 0
mirror of https://github.com/polysemy-research/polysemy.git synced 2024-11-23 09:15:22 +03:00
Code Issues Projects Releases Wiki Activity

rename Poly -> Semantic

Browse Source
This commit is contained in:
Sandy Maguire 2019-03-20 00:28:01 -04:00
parent 5d7d957b9a
commit 0684ea3dc6
6 changed files with 86 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
src/Polysemy.hs
View File

@ -32,148 +32,151 @@ import Polysemy.Lift
import Polysemy.Union
newtype Poly r a = Poly
{ runPoly
newtype Semantic r a = Semantic
{ runSemantic
:: ∀ m
. Monad m
=> (∀ x. Union r (Poly r) x -> m x)
=> (∀ x. Union r (Semantic r) x -> m x)
-> m a
}
usingPoly :: Monad m => (∀ x. Union r (Poly r) x -> m x) -> Poly r a -> m a
usingPoly k m = runPoly m k
{-# INLINE usingPoly #-}
usingSemantic :: Monad m => (∀ x. Union r (Semantic r) x -> m x) -> Semantic r a -> m a
usingSemantic k m = runSemantic m k
{-# INLINE usingSemantic #-}
instance Functor (Poly f) where
fmap f (Poly m) = Poly $ \k -> fmap f $ m k
instance Functor (Semantic f) where
fmap f (Semantic m) = Semantic $ \k -> fmap f $ m k
{-# INLINE fmap #-}
instance Applicative (Poly f) where
pure a = Poly $ const $ pure a
instance Applicative (Semantic f) where
pure a = Semantic $ const $ pure a
{-# INLINE pure #-}
Poly f <*> Poly a = Poly $ \k -> f k <*> a k
Semantic f <*> Semantic a = Semantic $ \k -> f k <*> a k
{-# INLINE (<*>) #-}
instance Monad (Poly f) where
instance Monad (Semantic f) where
return = pure
{-# INLINE return #-}
Poly ma >>= f = Poly $ \k -> do
Semantic ma >>= f = Semantic $ \k -> do
z <- ma k
runPoly (f z) k
runSemantic (f z) k
{-# INLINE (>>=) #-}
instance (Member (Lift IO) r) => MonadIO (Poly r) where
instance (Member (Lift IO) r) => MonadIO (Semantic r) where
liftIO = sendM
{-# INLINE liftIO #-}
instance MonadFix (Poly '[]) where
instance MonadFix (Semantic '[]) where
mfix f = a
where
a = f (run a)
liftPoly :: Union r (Poly r) a -> Poly r a
liftPoly u = Poly $ \k -> k u
{-# INLINE liftPoly #-}
liftSemantic :: Union r (Semantic r) a -> Semantic r a
liftSemantic u = Semantic $ \k -> k u
{-# INLINE liftSemantic #-}
hoistPoly :: (∀ x. Union r (Poly r) x -> Union r' (Poly r') x) -> Poly r a -> Poly r' a
hoistPoly nat (Poly m) = Poly $ \k -> m $ \u -> k $ nat u
{-# INLINE hoistPoly #-}
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 #-}
send :: Member e r => e (Poly r) a -> Poly r a
send = liftPoly . inj
send :: Member e r => e (Semantic r) a -> Semantic r a
send = liftSemantic . inj
{-# INLINE[3] send #-}
sendM :: Member (Lift m) r => m a -> Poly r a
sendM :: Member (Lift m) r => m a -> Semantic r a
sendM = send . Lift
{-# INLINE sendM #-}
run :: Poly '[] a -> a
run (Poly m) = runIdentity $ m absurdU
run :: Semantic '[] a -> a
run (Semantic m) = runIdentity $ m absurdU
{-# INLINE run #-}
runM :: Monad m => Poly '[Lift m] a -> m a
runM (Poly m) = m $ unLift . extract
runM :: Monad m => Semantic '[Lift m] a -> m a
runM (Semantic m) = m $ unLift . extract
{-# INLINE runM #-}
interpret
:: Effect e
=> (∀ x. e (Poly (e ': r)) x -> Poly r x)
-> Poly (e ': r) a
-> Poly r a
interpret f (Poly m) = m $ \u ->
=> (∀ x. e (Semantic (e ': r)) x -> Semantic r x)
-> Semantic (e ': r) a
-> Semantic r a
interpret f (Semantic m) = m $ \u ->
case decomp u of
Left x -> liftPoly $ hoist (interpret f) x
Left x -> liftSemantic $ hoist (interpret f) x
Right y -> f y
{-# INLINE interpret #-}
stateful
:: Effect e
=> (∀ x. e (Poly (e ': r)) x -> StateT s (Poly r) x)
=> (∀ x. e (Semantic (e ': r)) x -> StateT s (Semantic r) x)
-> s
-> Poly (e ': r) a
-> Poly r (s, a)
stateful f s (Poly m) = Poly $ \k ->
-> Semantic (e ': r) a
-> Semantic r (s, a)
stateful f s (Semantic m) = Semantic $ \k ->
fmap swap $ flip S.runStateT s $ m $ \u ->
case decomp u of
Left x -> S.StateT $ \s' ->
k . fmap swap
. weave (s', ()) (uncurry $ stateful' f)
$ x
Right y -> S.mapStateT (usingPoly k) $ f y
Right y -> S.mapStateT (usingSemantic k) $ f y
{-# INLINE stateful #-}
stateful'
:: Effect e
=> (∀ x. e (Poly (e ': r)) x -> StateT s (Poly r) x)
=> (∀ x. e (Semantic (e ': r)) x -> StateT s (Semantic r) x)
-> s
-> Poly (e ': r) a
-> Poly r (s, a)
-> Semantic (e ': r) a
-> Semantic r (s, a)
stateful' = stateful
{-# NOINLINE stateful' #-}
reinterpret
:: Effect f
=> (∀ x. f (Poly (f ': r)) x -> Poly (g ': r) x)
-> Poly (f ': r) a
-> Poly (g ': r) a
reinterpret f (Poly m) = Poly $ \k -> m $ \u ->
=> (∀ x. f (Semantic (f ': r)) x -> Semantic (g ': r) x)
-> Semantic (f ': r) a
-> Semantic (g ': r) a
reinterpret f (Semantic m) = Semantic $ \k -> m $ \u ->
case prjCoerce u of
Left x -> k $ hoist (reinterpret' f) $ x
Right y -> usingPoly k $ f y
Right y -> usingSemantic k $ f y
{-# INLINE[3] reinterpret #-}
reinterpret'
:: Effect f
=> (∀ x. f (Poly (f ': r)) x -> Poly (g ': r) x)
-> Poly (f ': r) a
-> Poly (g ': r) a
=> (∀ x. f (Semantic (f ': r)) x -> Semantic (g ': r) x)
-> Semantic (f ': r) a
-> Semantic (g ': r) a
reinterpret' = reinterpret
{-# NOINLINE reinterpret' #-}
runRelayS
:: Effect e
=> (∀ x. e (Poly (e ': r)) x -> s -> Poly r (s, x))
=> (∀ x. e (Semantic (e ': r)) x -> s -> Semantic r (s, x))
-> s
-> Poly (e ': r) a
-> Poly r (s, a)
-> Semantic (e ': r) a
-> Semantic r (s, a)
runRelayS f = stateful $ \e -> S.StateT $ fmap swap . f e
{-# INLINE runRelayS #-}

16
src/Polysemy/Error.hs
View File

@ -38,22 +38,26 @@ instance Effect (Error e) where
{-# INLINE hoist #-}
throw :: Member (Error e) r => e -> Poly r a
throw :: Member (Error e) r => e -> Semantic r a
throw = send . Throw
catch :: Member (Error e) r => Poly r a -> (e -> Poly r a) -> Poly r a
catch
:: Member (Error e) r
=> Semantic r a
-> (e -> Semantic r a)
-> Semantic r a
catch try handle = send $ Catch try handle id
runError :: Poly (Error e ': r) a -> Poly r (Either e a)
runError (Poly m) = Poly $ \k -> E.runExceptT $ m $ \u ->
runError :: Semantic (Error e ': r) a -> Semantic r (Either e a)
runError (Semantic m) = Semantic $ \k -> E.runExceptT $ m $ \u ->
case decomp u of
Left x -> E.ExceptT $ k $
weave (Right ()) (either (pure . Left) runError') x
Right (Throw e) -> E.throwE e
Right (Catch try handle kt) -> E.ExceptT $ do
let runIt = usingPoly k . runError'
let runIt = usingSemantic k . runError'
ma <- runIt try
case ma of
Right a -> pure . Right $ kt a
@ -65,7 +69,7 @@ runError (Poly m) = Poly $ \k -> E.runExceptT $ m $ \u ->
{-# INLINE runError #-}
runError' :: Poly (Error e ': r) a -> Poly r (Either e a)
runError' :: Semantic (Error e ': r) a -> Semantic r (Either e a)
runError' = runError
{-# NOINLINE runError' #-}

22
src/Polysemy/Resource.hs
View File

@ -43,10 +43,10 @@ instance Effect Resource where
bracket
:: Member Resource r
=> Poly r a
-> (a -> Poly r ())
-> (a -> Poly r b)
-> Poly r b
=> Semantic r a
-> (a -> Semantic r ())
-> (a -> Semantic r b)
-> Semantic r b
bracket alloc dealloc use = send $ Bracket alloc dealloc use id
{-# INLINE bracket #-}
@ -54,12 +54,12 @@ bracket alloc dealloc use = send $ Bracket alloc dealloc use id
runResource
:: forall r a
. Member (Lift IO) r
=> (∀ x. Poly r x -> IO x)
-> Poly (Resource ': r) a
-> Poly r a
=> (∀ x. Semantic r x -> IO x)
-> Semantic (Resource ': r) a
-> Semantic r a
runResource finish = interpret $ \case
Bracket alloc dealloc use k -> fmap k . sendM $
let runIt :: Poly (Resource ': r) x -> IO x
let runIt :: Semantic (Resource ': r) x -> IO x
runIt = finish . runResource' finish
in X.bracket
(runIt alloc)
@ -70,9 +70,9 @@ runResource finish = interpret $ \case
runResource'
:: Member (Lift IO) r
=> (∀ x. Poly r x -> IO x)
-> Poly (Resource ': r) a
-> Poly r a
=> (∀ x. Semantic r x -> IO x)
-> Semantic (Resource ': r) a
-> Semantic r a
runResource' = runResource
{-# NOINLINE runResource' #-}

12
src/Polysemy/State.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Polysemy.State
@ -18,6 +19,7 @@ module Polysemy.State
import qualified Control.Monad.Trans.State.Strict as S
import Polysemy
import Polysemy.Effect
import Polysemy.Effect.TH
data State s m a
@ -26,31 +28,31 @@ data State s m a
deriving (Functor, Effect)
get :: Member (State s) r => Poly r s
get :: Member (State s) r => Semantic r s
get = send $ Get id
{-# INLINE get #-}
put :: Member (State s) r => s -> Poly r ()
put :: Member (State s) r => s -> Semantic r ()
put s = send $ Put s ()
{-# INLINE put #-}
modify :: Member (State s) r => (s -> s) -> Poly r ()
modify :: Member (State s) r => (s -> s) -> Semantic r ()
modify f = do
s <- get
put $ f s
{-# INLINE modify #-}
runState :: s -> Poly (State s ': r) a -> Poly r (s, a)
runState :: s -> Semantic (State s ': r) a -> Semantic r (s, a)
runState = stateful $ \case
Get k -> fmap k S.get
Put s k -> S.put s >> pure k
{-# INLINE[3] runState #-}
{-# RULES "runState/reinterpret"
forall s e (f :: forall x. e (Poly (e ': r)) x -> Poly (State s ': r) x).
forall s e (f :: forall x. e (Semantic (e ': r)) x -> Semantic (State s ': r) x).
runState s (reinterpret f e) = runRelayS (\x s' -> runState s' $ f x) s e
#-}

2
src/Wtf.hs
View File

@ -8,7 +8,7 @@ module Wtf where
import Polysemy
import Polysemy.State
go :: Member (State Int) r => Poly r Int
go :: Member (State Int) r => Semantic r Int
go = do
n <- get
if n <= 0

2
test/FusionSpec.hs
View File

@ -42,7 +42,7 @@ spec = do
shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'hoist)
go :: Poly '[State Int] Int
go :: Semantic '[State Int] Int
go = do
n <- send (Get id)
if n <= 0