module Yesod.Pure.NoRoute
( module Yesod.Pure
, module Yesod.Pure.NoRoute
) where
import Yesod.Pure
import Data.Text (Text)
import Control.Applicative (Applicative (..), Alternative (..))
import Data.Monoid (Monoid (..))
data App = App (NoRouteDispatch ())
instance YesodDispatch App App where
yesodDispatch logger master@(App (NoRouteDispatch d _)) sub toMaster on404 _ =
dispatch (Just . AppRoute) d' logger master sub toMaster on404 (const on404)
where
d' m (AppRoute ps) = d m ps
instance RenderRoute App where
newtype Route App = AppRoute [Text]
deriving Eq
renderRoute (AppRoute x) = (x, [])
data NoRouteDispatch a = NoRouteDispatch (Text -> [Text] -> Maybe (GHandler App App ChooseRep)) (Maybe a)
instance Functor NoRouteDispatch where
fmap f (NoRouteDispatch x ma) = NoRouteDispatch x (fmap f ma)
instance Applicative NoRouteDispatch where
pure = NoRouteDispatch (\_ _ -> Nothing) . Just
NoRouteDispatch a f <*> NoRouteDispatch b x =
NoRouteDispatch (\m p -> a m p <|> b m p) (f <*> x)
instance Alternative NoRouteDispatch where
empty = NoRouteDispatch (\_ _ -> Nothing) Nothing
(<|>) = (*>)
instance Monoid (NoRouteDispatch a) where
mempty = empty
mappend = (<|>)
instance Monad NoRouteDispatch where
return = pure
NoRouteDispatch f Nothing >>= _ = NoRouteDispatch f Nothing
NoRouteDispatch a (Just x) >>= f = NoRouteDispatch a (Just ()) *> f x
serve :: HasReps a => GHandler App App a -> NoRouteDispatch ()
serve h =
NoRouteDispatch go (Just ())
where
go _ [] = Just $ fmap chooseRep h
go _ _ = Nothing
method :: Text -> NoRouteDispatch a -> NoRouteDispatch a
method x (NoRouteDispatch f a) =
NoRouteDispatch go a
where
go m ps
| m == x = f m ps
| otherwise = Nothing
static :: Text -> NoRouteDispatch a -> NoRouteDispatch a
static x (NoRouteDispatch f a) =
NoRouteDispatch go a
where
go _ [] = Nothing
go m (t:ts)
| t == x = f m ts
| otherwise = Nothing
dynamic :: PathPiece p => (p -> NoRouteDispatch b) -> NoRouteDispatch ()
dynamic f =
NoRouteDispatch go (Just ())
where
go _ [] = Nothing
go m (t:ts) =
case fromPathPiece t of
Nothing -> Nothing
Just p ->
let (NoRouteDispatch f' _) = f p
in f' m ts
multi :: PathMultiPiece ps => (ps -> NoRouteDispatch b) -> NoRouteDispatch ()
multi f =
NoRouteDispatch go (Just ())
where
go m ts =
case fromPathMultiPiece ts of
Nothing -> Nothing
Just ps ->
let (NoRouteDispatch f' _) = f ps
in f' m []