raise and writer effect

src/Polysemy.hs

@@ -10,6 +10,7 @@ module Polysemy
   , sendM
   , run
   , runM
+  , raise
   , Lift ()
   , usingSemantic
   , liftSemantic
@@ -20,6 +21,7 @@ import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Data.Functor.Identity
 import Polysemy.Lift
+import Polysemy.Effect
 import Polysemy.Union
 
 
@@ -88,6 +90,16 @@ hoistSemantic nat (Semantic m) = Semantic $ \k -> m $ \u -> k $ nat u
 {-# INLINE hoistSemantic #-}
 
 
+raise :: Semantic r a -> Semantic (e ': r) a
+raise = hoistSemantic $ hoist raise' . weaken
+{-# INLINE raise #-}
+
+
+raise' :: Semantic r a -> Semantic (e ': r) a
+raise' = raise
+{-# NOINLINE raise' #-}
+
+
 send :: Member e r => e (Semantic r) a -> Semantic r a
 send = liftSemantic . inj
 {-# INLINE[3] send #-}

src/Polysemy/Writer.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE BlockArguments  #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Polysemy.Writer where
+
+import Polysemy
+import Polysemy.Effect.New
+import Polysemy.State
+
+data Writer o m a
+  = Tell o a
+  | ∀ x. Listen (m x) (o -> x -> a)
+  | ∀ x. Censor (o -> o) (m x) (x -> a)
+
+deriving instance Functor (Writer o m)
+
+instance Effect (Writer o) where
+  weave s _ (Tell o k) = Tell o $ k <$ s
+  weave s distrib (Listen m k) =
+    Listen (distrib $ m <$ s) (fmap fmap k)
+  weave s distrib (Censor f m k) =
+    Censor f (distrib $ m <$ s) (fmap k)
+  {-# INLINE weave #-}
+
+  hoist = defaultHoist
+  {-# INLINE hoist #-}
+
+makeSemantic ''Writer
+
+
+runWriter
+    :: Monoid o
+    => Semantic (Writer o ': r) a
+    -> Semantic r (o, a)
+runWriter = runState mempty . reinterpret \case
+  Tell o k -> do
+    modify (<> o)
+    pure k
+  Listen m k -> do
+    (o, a) <- raise $ runWriter' m
+    pure $ k o a
+  Censor f m k -> do
+    (o, a) <- raise $ runWriter' m
+    modify (<> f o)
+    pure $ k a
+{-# INLINE runWriter #-}
+
+
+runWriter'
+    :: Monoid o
+    => Semantic (Writer o ': r) a
+    -> Semantic r (o, a)
+runWriter' = runWriter
+{-# NOINLINE runWriter' #-}
+