diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs index 9cb76bb7..402a913c 100644 --- a/yesod-routes/Yesod/Routes/TH.hs +++ b/yesod-routes/Yesod/Routes/TH.hs @@ -11,13 +11,18 @@ module Yesod.Routes.TH -- ** RenderRoute , mkRenderRouteClauses , mkRenderRouteInstance + -- ** Dispatch + , mkDispatchClause ) where import Language.Haskell.TH.Syntax -import Yesod.Core (Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece) +import Yesod.Core + ( Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece + ) import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) +import qualified Yesod.Routes.Dispatch as D data Resource = Resource { resourceName :: String @@ -115,3 +120,36 @@ mkRenderRouteInstance name ress = do return $ InstanceD [] (ConT ''RenderRoute `AppT` ConT (mkName name)) [ FunD (mkName "renderRoute") cls ] + +mkDispatchClause :: [Resource] -> Q Clause +mkDispatchClause ress = do + let routes = fmap ListE $ mapM toRoute ress + sub <- newName "sub" + mkey <- newName "mkey" + ts <- newName "ts" + master <- newName "master" + toMaster <- newName "toMaster" + let pats = + [ VarP sub + , VarP mkey + , VarP ts + , VarP master + , VarP toMaster + ] + + dispatch <- newName "dispatch" + body <- [|D.toDispatch $(routes)|] + return $ Clause + pats + (NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster])) + [FunD dispatch [Clause [] (NormalB body) []]] + where + toRoute :: Resource -> Q Exp + toRoute res = do + let ps = fmap ListE $ mapM toPiece $ resourcePieces res + let m = maybe [|False|] (const [|True|]) $ resourceMulti res + [|D.Route $(ps) $(m) undefined|] + + toPiece :: Piece -> Q Exp + toPiece (Static s) = [|D.Static $ pack $(lift s)|] + toPiece Dynamic{} = [|D.Dynamic|] diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index d7a657fe..ec5f1197 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -69,9 +69,11 @@ do , Resource "SubsiteR" [Static "subsite"] Nothing $ Subsite (ConT ''MySub) "getMySub" ] rrinst <- mkRenderRouteInstance "MyAppRoute" ress + dispatch <- mkDispatchClause ress return [ mkRouteType "MyAppRoute" ress , rrinst + , FunD (mkName "thDispatch") [dispatch] ] main :: IO () @@ -109,3 +111,7 @@ main = hspecX $ do it "renders wiki correctly" $ YC.renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], []) it "renders subsite correctly" $ YC.renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")])) @?= (["subsite", "foo", "bar"], [("baz", "bin")]) + + describe "thDispatch" $ do + let disp x = thDispatch () () [] () () + it "routes to root" $ disp [] @?= Just "this is the root"