Add Pass to Writer, replacing Censor. Fix semantics of listen (#169)

* Added Pass to Writer, replacing Censor. Fixed semantics of listen

* Swap order of elements in the Pass tuple

* Sometimes I'm bad! Fixed compile error.

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 81ab3886c51d2b5a58bab1b06a498983d76778f000144d42e36ecc84a0cfb3bb
+-- hash: 97a22d464c318fcae18ff92ed18f1367580a311610f0d5ea54de4e29a97b04de
 
 name:           polysemy
 version:        0.6.0.0
@@ -118,6 +118,7 @@ test-suite polysemy-test
       OutputSpec
       ThEffectSpec
       TypeErrors
+      WriterSpec
       Paths_polysemy
   hs-source-dirs:
       test

src/Polysemy/Writer.hs

@@ -8,6 +8,7 @@ module Polysemy.Writer
     -- * Actions
   , tell
   , listen
+  , pass
   , censor
 
     -- * Interpretations
@@ -27,10 +28,15 @@ import Polysemy.State
 data Writer o m a where
   Tell   :: o -> Writer o m ()
   Listen :: ∀ o m a. m a -> Writer o m (o, a)
-  Censor :: (o -> o) -> m a -> Writer o m a
+  Pass   :: m (o -> o, a) -> Writer o m a
 
 makeSem ''Writer
 
+censor :: Member (Writer o) r
+       => (o -> o)
+       -> Sem r a
+       -> Sem r a
+censor f m = pass (fmap ((,) f) m)
 
 ------------------------------------------------------------------------------
 -- | Transform an 'Output' effect into a 'Writer' effect.
@@ -50,15 +56,18 @@ runWriter
 runWriter = runState mempty . reinterpretH
   (\case
       Tell o -> do
-        modify (`mappend` o) >>= pureT
+        modify (<> o) >>= pureT
       Listen m -> do
         mm <- runT m
         -- TODO(sandy): this is stupid
         (o, fa) <- raise $ runWriter mm
+        modify (<> o)
         pure $ fmap (o, ) fa
-      Censor f m -> do
+      Pass m -> do
         mm <- runT m
-        ~(o, a) <- raise $ runWriter mm
-        modify (`mappend` f o)
-        pure a
+        (o, t) <- raise $ runWriter mm
+        ins <- getInspectorT
+        let f = maybe id fst (inspect ins t)
+        modify (<> f o)
+        pure (fmap snd t)
   )

test/WriterSpec.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module WriterSpec where
+
+import Test.Hspec
+
+import Polysemy
+import Polysemy.Error
+import Polysemy.Writer
+
+censor' :: forall e s a r
+        . (Member (Error e) r, Member (Writer s) r)
+        => (s -> s)
+        -> Sem r a
+        -> Sem r a
+censor' f m = do
+  res <- censor f $ fmap Right m `catch` (pure . Left)
+  case res of
+      Right res' -> return res'
+      Left e -> throw (e :: e)
+
+test1 :: (String, Either () ())
+test1 =
+    run
+  . runWriter
+  . runError $
+  do
+    tell "censoring"
+    censor @String
+      (drop 4)
+      (tell " not applied" *> throw ())
+    `catch`
+      (\(_ :: ()) -> pure ())
+
+test2 :: (String, Either () ())
+test2 =
+    run
+  . runWriter
+  . runError $
+  do
+    tell "censoring"
+    censor' @() @String
+      (drop 4)
+      (tell " not applied" *> throw ())
+    `catch`
+      (\(_ :: ()) -> pure ())
+
+test3 :: (String, (String, ()))
+test3 = run . runWriter $ listen (tell "and hear")
+
+spec :: Spec
+spec = describe "writer" $ do
+  it "should not censor" $ do
+    test1 `shouldBe` ("censoring not applied", Right ())
+
+  it "should censor" $ do
+    test2 `shouldBe` ("censoring applied", Right ())
+
+  it "should have a proper listen" $ do
+    test3 `shouldBe` ("and hear", ("and hear", ()))