diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 2475b436..5ce988da 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -210,7 +210,14 @@ mkYesodDispatch' sortedRes = do (NormalB body) [] where - go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = return onFail + go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + test <- mkSubsiteExp segments pieces id (master, mkey, constr, toSub) + just <- [|Just|] + app <- newName "app" + return $ CaseE test + [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] + ] go master mkey segments onFail ((constr, Simple pieces methods), Nothing) = do test <- mkSimpleExp segments pieces id (master, mkey, constr, methods) just <- [|Just|] @@ -288,6 +295,52 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do ] return exp +mkSubsiteExp segments [] frontVars (master, mkey, constr, toSub) = do + ds <- [|dispatchSubsite|] + let con = foldl' AppE (ConE $ mkName constr) $ frontVars [] + let s' = VarE (mkName toSub) `AppE` VarE master + let s = foldl' AppE s' $ frontVars [] + let app = ds `AppE` VarE master `AppE` VarE mkey `AppE` VarE segments `AppE` con `AppE` s + just <- [|Just|] + return $ just `AppE` app +mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do + srest <- newName "segments" + innerExp <- mkSubsiteExp srest pieces frontVars x + nothing <- [|Nothing|] + let exp = CaseE (VarE segments) + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB innerExp) + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSubsiteExp segments (SinglePiece s:pieces) frontVars x = do + srest <- newName "segments" + next' <- newName "next'" + innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + next <- newName "next" + fsp <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE (VarE segments) + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp + {- mkPat' (SinglePiece s:rest) url = do fsp <- [|either (const Nothing) Just . fromSinglePiece|]