mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-10-26 10:58:34 +03:00
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.
This commit is contained in:
parent
8a22cc29e1
commit
0d22cdaba0
@ -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
|
||||
|
@ -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)
|
||||
)
|
||||
|
59
test/WriterSpec.hs
Normal file
59
test/WriterSpec.hs
Normal file
@ -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", ()))
|
Loading…
Reference in New Issue
Block a user