module Web.Routes.RouteT where
import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty))
import Control.Monad (MonadPlus(mzero, mplus))
import Control.Monad.Fix (MonadFix(mfix))
type Link = String
newtype RouteT url m a = RouteT { unRouteT :: (url -> [(String, String)] -> Link) -> m a }
runRouteT :: RouteT url m a -> (url -> [(String, String)] -> Link) -> m a
runRouteT = unRouteT
mapRouteT :: (m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT f (RouteT m) = RouteT $ f . m
withRouteT :: ((url' -> [(String, String)] -> Link) -> (url -> [(String, String)] -> Link)) -> 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 -> [(String, String)] -> String)
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
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 (MonadFix m) => MonadFix (RouteT url m) where
mfix f = RouteT $ \ url -> mfix $ \ a -> unRouteT (f a) url
class ShowURL m where
type URL m
showURLParams :: (URL m) -> [(String, String)] -> m Link
instance (Monad m) => ShowURL (RouteT url m) where
type URL (RouteT url m) = url
showURLParams url params =
do showF <- askRouteT
return (showF url params)
showURL :: ShowURL m => URL m -> m Link
showURL url = showURLParams url []
nestURL :: (Monad m) => (url2 -> url1) -> RouteT url2 m a -> RouteT url1 m a
nestURL b = withRouteT (. b)
crossURL :: (Monad m) => (url2 -> url1) -> [(String, String)] -> RouteT url1 m (url2 -> Link)
crossURL f params =
do showF <- askRouteT
return $ \url2 -> showF (f url2) params