From 7f51c7fd2072604f0b0487af88156549901eee30 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 27 Jan 2011 20:02:51 +0200 Subject: [PATCH] Fixed some TH code for subsites --- Yesod/Core.hs | 8 ++++++++ Yesod/Dispatch.hs | 43 ++++++++++++++++++++++++++----------------- helloworld.hs | 5 ++++- 3 files changed, 38 insertions(+), 18 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 027a27f7..33ccafdb 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -102,6 +102,14 @@ class Eq (Route s) => YesodSubSite s y where -> (Route s -> Route y) -> s -> W.Application + dispatchToSubSubsite + :: (Yesod y, YesodSite y) + => y + -> Maybe CS.Key + -> [String] + -> (Route s -> Route y) + -> s + -> Maybe W.Application -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index cfc3e8a6..df341353 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -172,11 +172,15 @@ mkYesodGeneral name args clazzes isSub res = do then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") subsiteClauses <- catMaybes <$> mapM sc th' + let subSubsiteClauses = [] -- FIXME subSubsiteClauses nothing <- [|Nothing|] dds <- [|defaultDispatchSubsite|] let otherMethods = if isSub - then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []]] + then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []] + , FunD (mkName "dispatchToSubSubsite") + (subSubsiteClauses ++ [Clause [WildP, WildP, WildP, WildP, WildP] (NormalB nothing) []]) + ] else [ FunD (mkName "dispatchToSubsite") (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) ] @@ -189,10 +193,13 @@ mkYesodGeneral name args clazzes isSub res = do master <- newName "master" mkey <- newName "mkey" just <- [|Just|] - (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) + (pat', tma', rest, toMaster) + <- mkPat' pieces + (ConE $ mkName constr) + $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) ds <- [|dispatchSubsite|] - -- let toMaster = ConE (mkName "SubsiteR") - toMaster <- [|error "FIXME toMaster"|] + goodParse <- (`AppE` tma') <$> [|isJust|] + tma'' <- (`AppE` tma') <$> [|fromJust|] let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster fmap' <- [|(<$>)|] let body = InfixE (Just body') fmap' $ Just tma' @@ -200,24 +207,25 @@ mkYesodGeneral name args clazzes isSub res = do [ VarP master , VarP mkey , pat' - ] (NormalB body) [] + ] (GuardedB [(NormalG goodParse, body)]) [] sc _ = return Nothing - mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp) - mkPat' (MultiPiece _:_) _ = error "MultiPiece not allowed as part of a subsite" - mkPat' (StaticPiece s:rest) tma = do - (x, tma, rest') <- mkPat' rest tma + mkPat' :: [Piece] -> Exp -> Exp -> Q (Pat, Exp, Exp, Exp) + mkPat' (MultiPiece _:_) _ _ = error "MultiPiece not allowed as part of a subsite" + mkPat' (StaticPiece s:rest) toMaster tma = do + (x, tma, rest', toMaster') <- mkPat' rest toMaster tma let sp = LitP $ StringL s - return (InfixP sp (mkName ":") x, tma, rest') - mkPat' (SinglePiece s:rest) tma = do + return (InfixP sp (mkName ":") x, tma, rest', toMaster') + mkPat' (SinglePiece s:rest) toMaster tma = do fsp <- [|either (const Nothing) Just . fromSinglePiece|] v <- newName $ "var" ++ s be <- [|(<*>)|] let tma' = InfixE (Just tma) be $ Just $ fsp `AppE` VarE v - (x, tma'', rest) <- mkPat' rest tma' - return (InfixP (VarP v) (mkName ":") x, tma'', rest) - mkPat' [] parse = do + let toMaster' = toMaster `AppE` VarE v + (x, tma'', rest, toMaster'') <- mkPat' rest toMaster' tma' + return (InfixP (VarP v) (mkName ":") x, tma'', rest, toMaster'') + mkPat' [] toMaster parse = do rest <- newName "rest" - return (VarP rest, parse, VarE rest) + return (VarP rest, parse, VarE rest, toMaster) isStatic :: Piece -> Bool isStatic StaticPiece{} = True @@ -334,7 +342,6 @@ normalDispatch y key' segments env = Nothing -> badMethod Just h -> h --- FIXME address sub-subsites defaultDispatchSubsite :: (Yesod m, YesodSite m, YesodSubSite s m) => m -> Maybe Key -> [String] @@ -342,7 +349,9 @@ defaultDispatchSubsite -> s -> W.Application defaultDispatchSubsite y key' segments toMasterRoute s env = - yesodRunner y key' (fmap toMasterRoute murl) handler env + case dispatchToSubSubsite y key' segments toMasterRoute s of + Just app -> app env + Nothing -> yesodRunner y key' (fmap toMasterRoute murl) handler env where method = B.unpack $ W.requestMethod env murl = either (const Nothing) Just $ parsePathSegments (getSubSite' s y) segments diff --git a/helloworld.hs b/helloworld.hs index 29d37b6a..fd4e15da 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} import Yesod.Core import Yesod.Dispatch import Yesod.Content @@ -15,7 +16,9 @@ mkYesodSub "Subsite" [] [$parseRoutes| getSubRootR :: GHandler Subsite m RepPlain getSubRootR = do Subsite s <- getYesodSub - return $ RepPlain $ toContent $ "Hello Sub World: " ++ s + tm <- getRouteToMaster + render <- getUrlRender + return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR) data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } mkYesod "HelloWorld" [$parseRoutes|