haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed some dispatch bugs

Browse Source
This commit is contained in:
Michael Snoyman 2011-01-28 11:26:13 +02:00
parent af30b44ef2
commit 24b519ffa4
2 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
Yesod/Dispatch.hs
View File

@ -133,7 +133,7 @@ mkYesodGeneral name args clazzes isSub res = do
[ FunD (mkName "renderRoute") render [ FunD (mkName "renderRoute") render
] ]
let sortedRes = filter (not . isSubSite) th ++ filter isSubSite th let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th'
yd <- mkYesodDispatch' sortedRes yd <- mkYesodDispatch' sortedRes
let master = mkName "master" let master = mkName "master"
let ctx = if isSub let ctx = if isSub
@ -145,11 +145,11 @@ mkYesodGeneral name args clazzes isSub res = do
let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]] let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
return ([w, x, x'], [y]) return ([w, x, x'], [y])
isSubSite :: (String, Pieces) -> Bool isSubSite :: ((String, Pieces), a) -> Bool
isSubSite (_, SubSite{}) = True isSubSite ((_, SubSite{}), _) = True
isSubSite _ = False isSubSite _ = False
mkYesodDispatch' :: [(String, Pieces)] -> Q Clause mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause
mkYesodDispatch' sortedRes = do mkYesodDispatch' sortedRes = do
sub <- newName "sub" sub <- newName "sub"
master <- newName "master" master <- newName "master"
@ -163,14 +163,14 @@ mkYesodDispatch' sortedRes = do
(NormalB body) (NormalB body)
[] []
where where
go master sub toMasterRoute mkey segments onFail (constr, SubSite { ssPieces = pieces }) = do go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr) test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub)
app <- newName "app" app <- newName "app"
return $ CaseE test return $ CaseE test
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
] ]
go master sub toMasterRoute mkey segments onFail (constr, Simple pieces methods) = do go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods) test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)
just <- [|Just|] just <- [|Just|]
app <- newName "app" app <- newName "app"
@ -178,6 +178,7 @@ mkYesodDispatch' sortedRes = do
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
] ]
go _ _ _ _ _ _ _ = error "Invalid combination"
mkSimpleExp :: Exp -- ^ segments mkSimpleExp :: Exp -- ^ segments
-> [Piece] -> [Piece]
@ -195,7 +196,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
yr <- [|yesodRunner|] yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|] cr <- [|fmap chooseRep|]
let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
let runHandlerVars h = runHandler' $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
runHandler' h = NormalB $ yr `AppE` sub runHandler' h = NormalB $ yr `AppE` sub
`AppE` VarE master `AppE` VarE master
`AppE` toMasterRoute `AppE` toMasterRoute
@ -279,13 +280,15 @@ mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"
mkSubsiteExp :: Name -- ^ segments mkSubsiteExp :: Name -- ^ segments
-> [Piece] -> [Piece]
-> ([Exp] -> [Exp]) -- ^ variables already parsed -> ([Exp] -> [Exp]) -- ^ variables already parsed
-> (Name, Exp, Exp, Name, String) -- ^ master, sub, toMasterRoute, mkey, constructor -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub
-> Q Exp -> Q Exp
mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr) = do mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
yd <- [|yesodDispatch|] yd <- [|yesodDispatch|]
dot <- [|(.)|] dot <- [|(.)|]
let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars [] let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []
let app = yd `AppE` sub -- proper handling for sub-subsites
let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars []
let app = yd `AppE` sub'
`AppE` VarE mkey `AppE` VarE mkey
`AppE` VarE segments `AppE` VarE segments
`AppE` VarE master `AppE` VarE master

5
helloworld.hs
View File

@ -21,7 +21,10 @@ getSubRootR = do
render <- getUrlRender render <- getUrlRender
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR) return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR)
handleSubMultiR = return . RepPlain . toContent . show handleSubMultiR :: Strings -> GHandler Subsite m RepPlain
handleSubMultiR x = do
Subsite y <- getYesodSub
return . RepPlain . toContent . show $ (x, y)
data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
mkYesod "HelloWorld" [$parseRoutes| mkYesod "HelloWorld" [$parseRoutes|