/
Middleware.purs
94 lines (75 loc) · 3.18 KB
/
Middleware.purs
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
module Hyper.Middleware
( module QualifiedDo
, Middleware(..)
, evalMiddleware
, hoistMiddleware
, runMiddleware
, lift'
) where
import Prelude
import Control.Monad.Indexed (class IxApplicative, class IxApply, class IxBind, class IxFunctor, class IxMonad, ibind, ipure)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Data.Tuple (Tuple(..), snd)
import Hyper.Middleware.Class (class IxMonadMiddleware)
import Hyper.Middleware.QualifiedDo (bind, discard) as QualifiedDo
newtype Middleware m i o a = Middleware (i -> m (Tuple a o))
runMiddleware :: forall m i o a. Middleware m i o a -> i -> m (Tuple a o)
runMiddleware (Middleware m) x = m x
evalMiddleware :: forall m i o a. Functor m ⇒ Middleware m i o a -> i -> m o
evalMiddleware a s = map snd (runMiddleware a s)
hoistMiddleware :: forall f g i o a. (f ~> g) -> Middleware f i o a -> Middleware g i o a
hoistMiddleware f (Middleware k) = Middleware (f <<< k)
instance ixMonadMiddlewareMiddleware :: Applicative m ⇒ IxMonadMiddleware (Middleware m) where
getConn = Middleware $ \c -> pure (Tuple c c)
putConn c = Middleware $ \_ -> pure (Tuple unit c)
instance ixApplicativeMiddleware :: Monad m ⇒ IxApplicative (Middleware m) where
ipure x = Middleware $ \s -> pure (Tuple x s)
instance ixBindMiddleware :: Monad m ⇒ IxBind (Middleware m) where
ibind (Middleware ma) f =
Middleware $ \s ->
ma s >>= \(Tuple x s') ->
case f x of
Middleware a -> a s'
instance ixApplyMiddleware :: Monad m ⇒ IxApply (Middleware m) where
iapply f a =
Middleware $ \s ->
runMiddleware f s >>= \(Tuple f' s') ->
runMiddleware a s' >>= \(Tuple a' s'') ->
pure (Tuple (f' a') s'')
instance ixFunctorMiddleware :: Monad m ⇒ IxFunctor (Middleware m) where
imap f a =
Middleware $ \s ->
runMiddleware a s >>= \(Tuple a' s') ->
pure (Tuple (f a') s')
instance ixMonadMiddleware :: Monad m ⇒ IxMonad (Middleware m)
instance functorMiddleware :: Monad m => Functor (Middleware m i i) where
map f a =
Middleware $ \s ->
runMiddleware a s >>= \(Tuple a' s') ->
pure (Tuple (f a') s')
instance applyMiddleware :: Monad m => Apply (Middleware m i i) where
apply f a =
Middleware $ \s ->
runMiddleware f s >>= \(Tuple f' s') ->
runMiddleware a s' >>= \(Tuple a' s'') ->
pure (Tuple (f' a') s'')
instance applicativeMiddleware :: Monad m => Applicative (Middleware m i i) where
pure = ipure
instance bindMiddleware :: Monad m ⇒ Bind (Middleware m i i) where
bind = ibind
instance monadMiddleware :: (Monad m, Applicative m) => Monad (Middleware m i i)
instance monadEffMiddleware :: MonadEffect m ⇒ MonadEffect (Middleware m i i) where
liftEffect e = Middleware $ \s -> do
x <- liftEffect e
pure (Tuple x s)
instance monadAffMiddleware :: MonadAff m ⇒ MonadAff (Middleware m i i) where
liftAff e = Middleware $ \s -> do
x <- liftAff e
pure (Tuple x s)
-- TODO: Can this be written as an instance of MonadTrans? Can't get the type
-- arguments to line up properly...
lift' :: forall m i a. Monad m ⇒ m a -> Middleware m i i a
lift' a = Middleware $ \s -> do
x <- a
pure (Tuple x s)