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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Web.Route.RouteT
-- Copyright : (c) 2010 Jeremy Shaw
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : partners@seereason.com
-- Stability : experimental
-- Portability : portable
--
-- Declaration of the 'RouteT' monad transformer
-----------------------------------------------------------------------------
module Web.Routes.RouteT where
import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty))
import Control.Monad (MonadPlus(mzero, mplus))
import Control.Monad.Catch (MonadCatch(catch), MonadThrow(throwM))
import Control.Monad.Cont(MonadCont(callCC))
import Control.Monad.Error (MonadError(throwError, catchError))
#if !MIN_VERSION_base(4,13,0)
-- Control.Monad.Fail import is redundant since GHC 8.8.1
import Prelude hiding (fail)
import Control.Monad.Fail (MonadFail(..))
#endif
import Control.Monad.Fix (MonadFix(mfix))
import Control.Monad.Reader(MonadReader(ask,local))
import Control.Monad.RWS (MonadRWS)
import Control.Monad.State(MonadState(get,put))
import Control.Monad.Trans (MonadTrans(lift), MonadIO(liftIO))
import Control.Monad.Writer(MonadWriter(listen, tell, pass))
import Data.Text (Text)
-- * RouteT Monad Transformer
-- |monad transformer for generating URLs
newtype RouteT url m a = RouteT { unRouteT :: (url -> [(Text, Maybe Text)] -> Text) -> m a }
class (Monad m) => MonadRoute m where
type URL m
askRouteFn :: m (URL m -> [(Text, Maybe Text)] -> Text)
instance MonadCatch m => MonadCatch (RouteT url m) where
catch action handler =
RouteT $ \ fn -> catch (action' fn) (\ e -> handler' e fn)
where
action' = unRouteT action
handler' e = unRouteT (handler e)
instance MonadThrow m => MonadThrow (RouteT url m) where
throwM = throwM'
where
throwM' e = RouteT $ \ _fn -> throwM e
-- | convert a 'RouteT' based route handler to a handler that can be used with the 'Site' type
--
-- NOTE: this function used to be the same as 'unRouteT'. If you want the old behavior, just call 'unRouteT'.
runRouteT :: (url -> RouteT url m a)
-> ((url -> [(Text, Maybe Text)] -> Text) -> url -> m a)
runRouteT r = \f u -> (unRouteT (r u)) f
-- | Transform the computation inside a @RouteT@.
mapRouteT :: (m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT f (RouteT m) = RouteT $ f . m
-- | Execute a computation in a modified environment
withRouteT :: ((url' -> [(Text, Maybe Text)] -> Text) -> (url -> [(Text, Maybe Text)] -> Text)) -> RouteT url m a -> RouteT url' m a
withRouteT f (RouteT m) = RouteT $ m . f
liftRouteT :: m a -> RouteT url m a
liftRouteT m = RouteT (const m)
askRouteT :: (Monad m) => RouteT url m (url -> [(Text, Maybe Text)] -> Text)
askRouteT = RouteT return
instance (Functor m) => Functor (RouteT url m) where
fmap f = mapRouteT (fmap f)
instance (Applicative m) => Applicative (RouteT url m) where
pure = liftRouteT . pure
f <*> v = RouteT $ \ url -> unRouteT f url <*> unRouteT v url
instance (Alternative m) => Alternative (RouteT url m) where
empty = liftRouteT empty
m <|> n = RouteT $ \ url -> unRouteT m url <|> unRouteT n url
instance (Monad m) => Monad (RouteT url m) where
return = liftRouteT . return
m >>= k = RouteT $ \ url -> do
a <- unRouteT m url
unRouteT (k a) url
instance (MonadFail m) => MonadFail (RouteT url m) where
fail msg = liftRouteT (fail msg)
instance (MonadPlus m, Monad (RouteT url m)) => MonadPlus (RouteT url m) where
mzero = liftRouteT mzero
m `mplus` n = RouteT $ \ url -> unRouteT m url `mplus` unRouteT n url
instance (MonadCont m) => MonadCont (RouteT url m) where
callCC f = RouteT $ \url ->
callCC $ \c ->
unRouteT (f (\a -> RouteT $ \_ -> c a)) url
instance (MonadError e m) => MonadError e (RouteT url m) where
throwError = liftRouteT . throwError
catchError action handler = RouteT $ \f -> catchError (unRouteT action f) (\e -> unRouteT (handler e) f)
instance (MonadFix m) => MonadFix (RouteT url m) where
mfix f = RouteT $ \ url -> mfix $ \ a -> unRouteT (f a) url
instance (MonadIO m) => MonadIO (RouteT url m) where
liftIO = lift . liftIO
instance (MonadReader r m) => MonadReader r (RouteT url m) where
ask = liftRouteT ask
local f = mapRouteT (local f)
instance (MonadRWS r w s m) => MonadRWS r w s (RouteT url m)
instance (MonadState s m) => MonadState s (RouteT url m) where
get = liftRouteT get
put s = liftRouteT $ put s
instance MonadTrans (RouteT url) where
lift = liftRouteT
instance (MonadWriter w m) => MonadWriter w (RouteT url m) where
tell w = liftRouteT $ tell w
listen m = mapRouteT listen m
pass m = mapRouteT pass m
instance (Monad m) => MonadRoute (RouteT url m) where
type URL (RouteT url m) = url
askRouteFn = askRouteT
showURL :: (MonadRoute m) => URL m -> m Text
showURL url =
do showFn <- askRouteFn
return (showFn url [])
showURLParams :: (MonadRoute m) => URL m -> [(Text, Maybe Text)] -> m Text
showURLParams url params =
do showFn <- askRouteFn
return (showFn url params)
nestURL :: (url1 -> url2) -> RouteT url1 m a -> RouteT url2 m a
nestURL transform (RouteT r) =
do RouteT $ \showFn ->
r (\url params -> showFn (transform url) params)
|
