diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index b92df293..88bf8333 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -203,7 +203,7 @@ getAllPairs (x:xs) = map ((,) x) xs ++ getAllPairs xs checkPatterns :: (MonadFailure OverlappingPatterns m, MonadFailure InvalidResourcePattern m) => [ResourcePattern] - -> m [RP] -- FIXME + -> m [RP] checkPatterns rpss = do rps <- mapM (runKleisli $ Kleisli return &&& Kleisli readRP) rpss let overlaps' = concatMap helper $ getAllPairs rps @@ -291,10 +291,9 @@ rpnodesTH ns = do cpb <- [|doesPatternMatch|] let r' = VarE $ mkName "resource" let g = cpb `AppE` rp' `AppE` r' - vm' <- liftVerbMap vm $ countParams rp - vm'' <- applyUrlParams rp r' vm' - let vm''' = LamE [VarP $ mkName "verb"] vm'' - return (NormalG g, vm''') + vm' <- liftVerbMap vm r' rp + let vm'' = LamE [VarP $ mkName "verb"] vm' + return (NormalG g, vm'') data UrlParam = SlurpParam { slurpParam :: [String] } | StringParam { stringParam :: String } @@ -339,12 +338,6 @@ applyUrlParams rp@(RP rpps) r f = do rest' <- helper (i + 1) rest return $ slurp `AppE` rp' `AppE` r `AppE` i' : rest' -countParams :: RP -> Int -countParams (RP rpps) = helper 0 rpps where - helper i [] = i - helper i (Static _:rest) = helper i rest - helper i (_:rest) = helper (i + 1) rest - instance Lift RP where lift (RP rpps) = do rpps' <- lift rpps @@ -363,26 +356,34 @@ instance Lift RPP where lift (Slurp s) = do sl <- [|Slurp|] return $ sl `AppE` (LitE $ StringL s) -liftVerbMap :: VerbMap -> Int -> Q Exp -liftVerbMap (AllVerbs s) _ = do - cr <- [|(.) (fmap chooseRep)|] - return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb")) -liftVerbMap (Verbs vs) params = do - cr0 <- [|fmap chooseRep|] - cr1 <- [|(.) (fmap chooseRep)|] - let cr = if params == 0 then cr0 else cr1 - return $ CaseE (VarE $ mkName "verb") - $ map (helper cr) vs ++ [whenNotFound] +liftVerbMap :: VerbMap -> Exp -> RP -> Q Exp +liftVerbMap (AllVerbs s) r rp = do + -- handler function + let f = VarE $ mkName s + -- applied to the verb + let f' = f `AppE` VarE (mkName "verb") + -- apply all the url params + f'' <- applyUrlParams rp r f' + -- and apply chooseRep + cr <- [|fmap chooseRep|] + let f''' = cr `AppE` f'' + return f''' +liftVerbMap (Verbs vs) r rp = do + cr <- [|fmap chooseRep|] + vs' <- mapM (helper cr) vs + return $ CaseE (VarE $ mkName "verb") $ vs' ++ [whenNotFound] where - helper :: Exp -> (Verb, String) -> Match - helper cr (v, f) = - Match (ConP (mkName $ show v) []) - (NormalB $ cr `AppE` VarE (mkName f)) - [] + helper :: Exp -> (Verb, String) -> Q Match + helper cr (v, fName) = do + let f = VarE $ mkName fName + f' <- applyUrlParams rp r f + let f'' = cr `AppE` f' + let con = ConP (mkName $ show v) [] + return $ Match con (NormalB f'') [] whenNotFound :: Match whenNotFound = Match WildP - (NormalB $ LamE (replicate params WildP) $ VarE $ mkName "notFound") + (NormalB $ VarE $ mkName "notFound") [] strToExp :: Bool -> String -> Q Exp diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 46faac53..c0f03e3a 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -21,6 +21,10 @@ pageUpdate :: String -> Handler MyYesod RepChooser pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] userInfo :: Int -> Handler MyYesod HtmlObject userInfo i = return $ toHtmlObject ["userInfo", show i] +userVariable :: Int -> String -> Handler MyYesod HtmlObject +userVariable i s = return $ toHtmlObject ["userVariable", show i, s] +userPage :: Int -> [String] -> Handler MyYesod HtmlObject +userPage i p = return $ toHtmlObject ["userPage", show i, show p] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler" @@ -38,6 +42,10 @@ handler = [$resources| Post: pageUpdate /user/#id/: Get: userInfo +/user/#id/profile/$variable/: + Get: userVariable +/user/#id/page/*page/: + Get: userPage |] ph :: Handler MyYesod RepChooser -> IO () @@ -57,3 +65,4 @@ main = do ph $ handler ["user"] Get ph $ handler ["user", "five"] Get ph $ handler ["user", "5"] Get + ph $ handler ["user", "5", "profile", "email"] Get