rename Poly -> Semantic

src/Polysemy.hs

@@ -32,148 +32,151 @@ import           Polysemy.Lift
 import           Polysemy.Union
 
 
-newtype Poly r a = Poly
+newtype Semantic r a = Semantic
-  { runPoly
+  { 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
+usingSemantic :: Monad m => (∀ x. Union r (Semantic r) x -> m x) -> Semantic r a -> m a
-usingPoly k m = runPoly m k
+usingSemantic k m = runSemantic m k
-{-# INLINE usingPoly #-}
+{-# INLINE usingSemantic #-}
 
 
-instance Functor (Poly f) where
+instance Functor (Semantic f) where
-  fmap f (Poly m) = Poly $ \k -> fmap f $ m k
+  fmap f (Semantic m) = Semantic $ \k -> fmap f $ m k
   {-# INLINE fmap #-}
 
 
-instance Applicative (Poly f) where
+instance Applicative (Semantic f) where
-  pure a = Poly $ const $ pure a
+  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
+liftSemantic :: Union r (Semantic r) a -> Semantic r a
-liftPoly u = Poly $ \k -> k u
+liftSemantic u = Semantic $ \k -> k u
-{-# INLINE liftPoly #-}
+{-# INLINE liftSemantic #-}
 
 
-hoistPoly :: (∀ x. Union r (Poly r) x -> Union r' (Poly r') x) -> Poly r a -> Poly r' a
+hoistSemantic
-hoistPoly nat (Poly m) = Poly $ \k -> m $ \u -> k $ nat u
+    :: (∀ x. Union r (Semantic r) x -> Union r' (Semantic r') x)
-{-# INLINE hoistPoly #-}
+    -> 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 :: Member e r => e (Semantic r) a -> Semantic r a
-send = liftPoly . inj
+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 :: Semantic '[] a -> a
-run (Poly m) = runIdentity $ m absurdU
+run (Semantic m) = runIdentity $ m absurdU
 {-# INLINE run #-}
 
 
-runM :: Monad m => Poly '[Lift m] a -> m a
+runM :: Monad m => Semantic '[Lift m] a -> m a
-runM (Poly m) = m $ unLift . extract
+runM (Semantic m) = m $ unLift . extract
 {-# INLINE runM #-}
 
 
 interpret
     :: Effect e
-    => (∀ x. e (Poly (e ': r)) x -> Poly r x)
+    => (∀ x. e (Semantic (e ': r)) x -> Semantic r x)
-    -> Poly (e ': r) a
+    -> Semantic (e ': r) a
-    -> Poly r a
+    -> Semantic r a
-interpret f (Poly m) = m $ \u ->
+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
+    -> Semantic (e ': r) a
-    -> Poly r (s, a)
+    -> Semantic r (s, a)
-stateful f s (Poly m) = Poly $ \k ->
+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
+    -> Semantic (e ': r) a
-    -> Poly r (s, a)
+    -> Semantic r (s, a)
 stateful' = stateful
 {-# NOINLINE stateful' #-}
 
 
 reinterpret
     :: Effect f
-    => (∀ x. f (Poly (f ': r)) x -> Poly (g ': r) x)
+    => (∀ x. f (Semantic (f ': r)) x -> Semantic (g ': r) x)
-    -> Poly (f ': r) a
+    -> Semantic (f ': r) a
-    -> Poly (g ': r) a
+    -> Semantic (g ': r) a
-reinterpret f (Poly m) = Poly $ \k -> m $ \u ->
+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)
+    => (∀ x. f (Semantic (f ': r)) x -> Semantic (g ': r) x)
-    -> Poly (f ': r) a
+    -> Semantic (f ': r) a
-    -> Poly (g ': 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
+    -> Semantic (e ': r) a
-    -> Poly r (s, a)
+    -> Semantic r (s, a)
 runRelayS f = stateful $ \e -> S.StateT $ fmap swap . f e
 {-# INLINE runRelayS #-}
 

src/Polysemy/Error.hs

@@ -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 :: Semantic (Error e ': r) a -> Semantic r (Either e a)
-runError (Poly m) = Poly $ \k -> E.runExceptT $ m $ \u ->
+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' #-}
 

src/Polysemy/Resource.hs

@@ -43,10 +43,10 @@ instance Effect Resource where
 
 bracket
     :: Member Resource r
-    => Poly r a
+    => Semantic r a
-    -> (a -> Poly r ())
+    -> (a -> Semantic r ())
-    -> (a -> Poly r b)
+    -> (a -> Semantic r b)
-    -> Poly 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)
+    => (∀ x. Semantic r x -> IO x)
-    -> Poly (Resource ': r) a
+    -> Semantic (Resource ': r) a
-    -> Poly 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)
+    => (∀ x. Semantic r x -> IO x)
-    -> Poly (Resource ': r) a
+    -> Semantic (Resource ': r) a
-    -> Poly r a
+    -> Semantic r a
 runResource' = runResource
 {-# NOINLINE runResource' #-}
 

src/Polysemy/State.hs

@@ -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
      #-}
 

src/Wtf.hs

@@ -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

test/FusionSpec.hs

@@ -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