/
Writer.hs
76 lines (65 loc) · 2.42 KB
/
Writer.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
{-# LANGUAGE AllowAmbiguousTypes #-}
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
{- |
Copyright : (c) 2023 Yamada Ryo
License : MPL-2.0 (see the file LICENSE)
Maintainer : ymdfield@outlook.jp
Stability : experimental
Portability : portable
Interpreter and elaborator for the t'Control.Effect.Class.Writer.Writer' effect class.
See [README.md](https://github.com/sayo-hs/heftia/blob/master/README.md).
-}
module Control.Effect.Handler.Heftia.Writer where
import Control.Effect.Class (type (~>))
import Control.Effect.Class.Writer (Tell (tell), TellI (Tell), WriterS (Censor, Listen))
import Control.Effect.Freer (Fre, intercept, interposeT, interpretK, interpretT, type (<|))
import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT)
import Control.Monad.Trans.Writer.CPS qualified as T
import Data.Function ((&))
import Data.Tuple (swap)
elaborateWriterT ::
forall w m es.
(Monad m, Monoid w, TellI w <| es) =>
WriterS w (Fre es m) ~> Fre es m
elaborateWriterT = \case
Listen m -> listenT m
Censor f m -> m & intercept @(TellI w) \(Tell w) -> Tell $ f w
elaborateWriterTransactionalT ::
forall w m es.
(Monad m, Monoid w, TellI w <| es) =>
WriterS w (Fre es m) ~> Fre es m
elaborateWriterTransactionalT = \case
Listen m -> listenT m
Censor f m -> do
(a, w) <- confiscateT m
tell $ f w
pure a
listenT ::
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a ->
Fre es m (a, w)
listenT m = do
(a, w) <- confiscateT m
tell w
pure (a, w)
{-# INLINE listenT #-}
confiscateT ::
forall w m es a.
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a ->
Fre es m (a, w)
confiscateT = runWriterT . interposeT @(TellI w) \(Tell w) -> T.tell w
{-# INLINE confiscateT #-}
interpretTell :: (Monad m, Monoid w) => Fre (TellI w ': es) m a -> Fre es m (w, a)
interpretTell = fmap swap . runWriterT . interpretTellT
{-# INLINE interpretTell #-}
interpretTellT :: (Monad m, Monoid w) => Fre (TellI w ': es) m a -> WriterT w (Fre es m) a
interpretTellT = interpretT \(Tell w) -> T.tell w
{-# INLINE interpretTellT #-}
interpretTellK :: (Monad m, Monoid w) => Fre (TellI w ': es) m a -> Fre es m (w, a)
interpretTellK =
interpretK (pure . (mempty,)) \k (Tell w) -> do
(w', r) <- k ()
pure (w <> w', r)