{-# 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 { forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
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 :: forall e a.
Exception e =>
RouteT url m a -> (e -> RouteT url m a) -> RouteT url m a
catch RouteT url m a
action e -> RouteT url m a
handler =
        forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \ url -> [(Text, Maybe Text)] -> Text
fn -> forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch ((url -> [(Text, Maybe Text)] -> Text) -> m a
action' url -> [(Text, Maybe Text)] -> Text
fn) (\ e
e -> e -> (url -> [(Text, Maybe Text)] -> Text) -> m a
handler' e
e url -> [(Text, Maybe Text)] -> Text
fn)
        where
          action' :: (url -> [(Text, Maybe Text)] -> Text) -> m a
action' = forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
action
          handler' :: e -> (url -> [(Text, Maybe Text)] -> Text) -> m a
handler' e
e = forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (e -> RouteT url m a
handler e
e)

instance MonadThrow m => MonadThrow (RouteT url m) where
    throwM :: forall e a. Exception e => e -> RouteT url m a
throwM = forall {m :: * -> *} {e} {url} {a}.
(MonadThrow m, Exception e) =>
e -> RouteT url m a
throwM'
        where
          throwM' :: e -> RouteT url m a
throwM' e
e = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \ url -> [(Text, Maybe Text)] -> Text
_fn -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
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 :: forall url (m :: * -> *) a.
(url -> RouteT url m a)
-> (url -> [(Text, Maybe Text)] -> Text) -> url -> m a
runRouteT url -> RouteT url m a
r = \url -> [(Text, Maybe Text)] -> Text
f url
u -> (forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (url -> RouteT url m a
r url
u)) url -> [(Text, Maybe Text)] -> Text
f

-- | Transform the computation inside a @RouteT@.
mapRouteT :: (m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT :: forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT m a -> n b
f (RouteT (url -> [(Text, Maybe Text)] -> Text) -> m a
m) = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ m a -> n b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (url -> [(Text, Maybe Text)] -> Text) -> m a
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 :: forall url' url (m :: * -> *) a.
((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url m a -> RouteT url' m a
withRouteT (url' -> [(Text, Maybe Text)] -> Text)
-> url -> [(Text, Maybe Text)] -> Text
f (RouteT (url -> [(Text, Maybe Text)] -> Text) -> m a
m) = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ (url -> [(Text, Maybe Text)] -> Text) -> m a
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. (url' -> [(Text, Maybe Text)] -> Text)
-> url -> [(Text, Maybe Text)] -> Text
f

liftRouteT :: m a -> RouteT url m a
liftRouteT :: forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT m a
m = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT (forall a b. a -> b -> a
const m a
m)

askRouteT :: (Monad m) => RouteT url m (url -> [(Text, Maybe Text)] -> Text)
askRouteT :: forall (m :: * -> *) url.
Monad m =>
RouteT url m (url -> [(Text, Maybe Text)] -> Text)
askRouteT = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall (m :: * -> *) a. Monad m => a -> m a
return

instance (Functor m) => Functor (RouteT url m) where
  fmap :: forall a b. (a -> b) -> RouteT url m a -> RouteT url m b
fmap a -> b
f = forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)

instance (Applicative m) => Applicative (RouteT url m) where
  pure :: forall a. a -> RouteT url m a
pure = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  RouteT url m (a -> b)
f <*> :: forall a b.
RouteT url m (a -> b) -> RouteT url m a -> RouteT url m b
<*> RouteT url m a
v = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \ url -> [(Text, Maybe Text)] -> Text
url -> forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m (a -> b)
f url -> [(Text, Maybe Text)] -> Text
url forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
v url -> [(Text, Maybe Text)] -> Text
url

instance (Alternative m) => Alternative (RouteT url m) where
    empty :: forall a. RouteT url m a
empty   = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall (f :: * -> *) a. Alternative f => f a
empty
    RouteT url m a
m <|> :: forall a. RouteT url m a -> RouteT url m a -> RouteT url m a
<|> RouteT url m a
n = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \ url -> [(Text, Maybe Text)] -> Text
url -> forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
m url -> [(Text, Maybe Text)] -> Text
url forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
n url -> [(Text, Maybe Text)] -> Text
url

instance (Monad m) => Monad (RouteT url m) where
    return :: forall a. a -> RouteT url m a
return   = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
    RouteT url m a
m >>= :: forall a b.
RouteT url m a -> (a -> RouteT url m b) -> RouteT url m b
>>= a -> RouteT url m b
k  = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \ url -> [(Text, Maybe Text)] -> Text
url -> do
        a
a <- forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
m url -> [(Text, Maybe Text)] -> Text
url
        forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (a -> RouteT url m b
k a
a) url -> [(Text, Maybe Text)] -> Text
url

instance (MonadFail m) => MonadFail (RouteT url m) where
    fail :: forall a. String -> RouteT url m a
fail String
msg = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg)

instance (MonadPlus m, Monad (RouteT url m)) => MonadPlus (RouteT url m) where
    mzero :: forall a. RouteT url m a
mzero       = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall (m :: * -> *) a. MonadPlus m => m a
mzero
    RouteT url m a
m mplus :: forall a. RouteT url m a -> RouteT url m a -> RouteT url m a
`mplus` RouteT url m a
n = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \ url -> [(Text, Maybe Text)] -> Text
url -> forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
m url -> [(Text, Maybe Text)] -> Text
url forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
n url -> [(Text, Maybe Text)] -> Text
url

instance (MonadCont m) => MonadCont (RouteT url m) where
    callCC :: forall a b.
((a -> RouteT url m b) -> RouteT url m a) -> RouteT url m a
callCC (a -> RouteT url m b) -> RouteT url m a
f = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \url -> [(Text, Maybe Text)] -> Text
url ->
        forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC forall a b. (a -> b) -> a -> b
$ \a -> m b
c ->
        forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT ((a -> RouteT url m b) -> RouteT url m a
f (\a
a -> forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \url -> [(Text, Maybe Text)] -> Text
_ -> a -> m b
c a
a)) url -> [(Text, Maybe Text)] -> Text
url

instance (MonadError e m) => MonadError e (RouteT url m) where
  throwError :: forall a. e -> RouteT url m a
throwError = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a. RouteT url m a -> (e -> RouteT url m a) -> RouteT url m a
catchError RouteT url m a
action e -> RouteT url m a
handler = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \url -> [(Text, Maybe Text)] -> Text
f -> forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT RouteT url m a
action url -> [(Text, Maybe Text)] -> Text
f) (\e
e -> forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (e -> RouteT url m a
handler e
e) url -> [(Text, Maybe Text)] -> Text
f)

instance (MonadFix m) => MonadFix (RouteT url m) where
    mfix :: forall a. (a -> RouteT url m a) -> RouteT url m a
mfix a -> RouteT url m a
f = forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \ url -> [(Text, Maybe Text)] -> Text
url -> forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \ a
a -> forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (a -> RouteT url m a
f a
a) url -> [(Text, Maybe Text)] -> Text
url

instance (MonadIO m) => MonadIO (RouteT url m) where
  liftIO :: forall a. IO a -> RouteT url m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance (MonadReader r m) => MonadReader r (RouteT url m) where
  ask :: RouteT url m r
ask   = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (r -> r) -> RouteT url m a -> RouteT url m a
local r -> r
f = forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
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 :: RouteT url m s
get = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> RouteT url m ()
put s
s = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s

instance MonadTrans (RouteT url) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> RouteT url m a
lift = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT

instance (MonadWriter w m) => MonadWriter w (RouteT url m) where
  tell :: w -> RouteT url m ()
tell   w
w = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
  listen :: forall a. RouteT url m a -> RouteT url m (a, w)
listen RouteT url m a
m = forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen RouteT url m a
m
  pass :: forall a. RouteT url m (a, w -> w) -> RouteT url m a
pass   RouteT url m (a, w -> w)
m = forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass   RouteT url m (a, w -> w)
m

instance (Monad m) => MonadRoute (RouteT url m) where
    type URL (RouteT url m) = url
    askRouteFn :: RouteT url m (URL (RouteT url m) -> [(Text, Maybe Text)] -> Text)
askRouteFn = forall (m :: * -> *) url.
Monad m =>
RouteT url m (url -> [(Text, Maybe Text)] -> Text)
askRouteT

showURL :: (MonadRoute m) => URL m -> m Text
showURL :: forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL m
url =
    do URL m -> [(Text, Maybe Text)] -> Text
showFn <- forall (m :: * -> *).
MonadRoute m =>
m (URL m -> [(Text, Maybe Text)] -> Text)
askRouteFn
       forall (m :: * -> *) a. Monad m => a -> m a
return (URL m -> [(Text, Maybe Text)] -> Text
showFn URL m
url [])

showURLParams  :: (MonadRoute m) => URL m -> [(Text, Maybe Text)] -> m Text
showURLParams :: forall (m :: * -> *).
MonadRoute m =>
URL m -> [(Text, Maybe Text)] -> m Text
showURLParams URL m
url [(Text, Maybe Text)]
params =
    do URL m -> [(Text, Maybe Text)] -> Text
showFn <- forall (m :: * -> *).
MonadRoute m =>
m (URL m -> [(Text, Maybe Text)] -> Text)
askRouteFn
       forall (m :: * -> *) a. Monad m => a -> m a
return (URL m -> [(Text, Maybe Text)] -> Text
showFn URL m
url [(Text, Maybe Text)]
params)

nestURL :: (url1 -> url2) -> RouteT url1 m a -> RouteT url2 m a
nestURL :: forall url1 url2 (m :: * -> *) a.
(url1 -> url2) -> RouteT url1 m a -> RouteT url2 m a
nestURL url1 -> url2
transform (RouteT (url1 -> [(Text, Maybe Text)] -> Text) -> m a
r) =
    do forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT forall a b. (a -> b) -> a -> b
$ \url2 -> [(Text, Maybe Text)] -> Text
showFn ->
           (url1 -> [(Text, Maybe Text)] -> Text) -> m a
r (\url1
url [(Text, Maybe Text)]
params -> url2 -> [(Text, Maybe Text)] -> Text
showFn (url1 -> url2
transform url1
url) [(Text, Maybe Text)]
params)