module Yesod.Routes.TH.ParseRoute
(
mkParseRouteInstance
) where
import Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax
import Data.Text (pack)
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Yesod.Routes.Class
import qualified Yesod.Routes.Dispatch as D
import Data.List (foldl')
import Control.Applicative ((<$>))
import Data.Maybe (catMaybes)
import Control.Monad (forM)
import Control.Monad (join)
mkParseRouteClauses :: [ResourceTree a] -> Q [Clause]
mkParseRouteClauses ress' = do
pieces <- newName "pieces0"
dispatch <- newName "dispatch"
query <- newName "_query"
routes <- mapM (buildRoute query) ress
toDispatch <- [|D.toDispatch|]
let dispatchFun = FunD dispatch
[Clause
[]
(NormalB $ toDispatch `AppE` ListE routes)
[]
]
join' <- [|join|]
let body = join' `AppE` (VarE dispatch `AppE` VarE pieces)
return $ return $ Clause
[TupP [VarP pieces, VarP query]]
(NormalB body)
[dispatchFun]
where
ress = map noMethods $ flatten ress'
noMethods (FlatResource a b c d) = FlatResource a b c $ noMethods' d
noMethods' (Methods a _) = Methods a []
noMethods' (Subsite a b) = Subsite a b
mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance typ ress = do
cls <- mkParseRouteClauses ress
return $ InstanceD [] (ConT ''ParseRoute `AppT` typ)
[ FunD 'parseRoute cls
]
buildRoute :: Name -> FlatResource a -> Q Exp
buildRoute query (FlatResource parents name resPieces resDisp) = do
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
isMulti <-
case resDisp of
Methods Nothing _ -> [|False|]
_ -> [|True|]
[|D.Route
$(return routePieces)
$(return isMulti)
$(routeArg3
query
parents
name
(map snd allPieces)
resDisp)
|]
where
allPieces = concat $ map snd parents ++ [resPieces]
routeArg3 :: Name
-> [(String, [(CheckOverlap, Piece a)])]
-> String
-> [Piece a]
-> Dispatch a
-> Q Exp
routeArg3 query parents name resPieces resDisp = do
pieces <- newName "pieces"
xs <- forM resPieces $ \piece ->
case piece of
Static _ -> return Nothing
Dynamic _ -> Just <$> newName "x"
ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do
y <- newName $ "y" ++ show (i :: Int)
return (x, y)
xrest <- newName "xrest"
yrest <- newName "yrest"
pat <-
case resDisp of
Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs
_ -> do
let cons = mkName ":"
return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs
fromPathPiece' <- [|fromPathPiece|]
xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)
(reststmts, yrest') <-
case resDisp of
Methods (Just _) _ -> do
fromPathMultiPiece' <- [|fromPathMultiPiece|]
return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
_ -> return ([], [])
caller <- buildCaller query xrest parents name resDisp $ map snd ys ++ yrest'
just <- [|Just|]
let stmts = concat
[ xstmts
, reststmts
, [NoBindS $ just `AppE` caller]
]
errorMsg <- [|error "Invariant violated"|]
let matches =
[ Match pat (NormalB $ DoE stmts) []
, Match WildP (NormalB errorMsg) []
]
return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
buildCaller :: Name
-> Name
-> [(String, [(CheckOverlap, Piece a)])]
-> String
-> Dispatch a
-> [Name]
-> Q Exp
buildCaller query xrest parents name resDisp ys = do
let route = routeFromDynamics parents name ys
case resDisp of
Methods _ _ -> [|Just $(return route)|]
Subsite _ _ -> [|fmap $(return route) $ parseRoute ($(return $ VarE xrest), $(return $ VarE query))|]
convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|]
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])]
-> String
-> [Name]
-> Exp
routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
routeFromDynamics ((parent, pieces):rest) name ys =
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
where
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
isDynamic Dynamic{} = True
isDynamic _ = False
here = map VarE here' ++ [routeFromDynamics rest name ys']