diff --git a/yesod-routes/Yesod/Routes/TH/Simple.hs b/yesod-routes/Yesod/Routes/TH/Simple.hs index f589b367..d8ed1b33 100644 --- a/yesod-routes/Yesod/Routes/TH/Simple.hs +++ b/yesod-routes/Yesod/Routes/TH/Simple.hs @@ -1,57 +1,175 @@ {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} module Yesod.Routes.TH.Simple where +import Prelude hiding (exp) import Yesod.Routes.TH import Language.Haskell.TH.Syntax import Web.PathPieces -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, catMaybes) import Control.Monad (forM) import Data.List (foldl') import Data.ByteString (ByteString) +import Control.Arrow (second) -mkSimpleDispatchClauses :: MkDispatchSettings -> [ResourceTree a] -> Q [Clause] -mkSimpleDispatchClauses MkDispatchSettings {..} (flatten -> resources) = do - clauses <- mapM go resources - clause404 <- mkClause404 - return $ clauses ++ [clause404] +data SDC = SDC + { clause404 :: Clause + , extraParams :: [Exp] + , extraCons :: [Exp] + , envExp :: Exp + , reqExp :: Exp + } + +mkSimpleDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause +mkSimpleDispatchClause MkDispatchSettings {..} resources = do + envName <- newName "env" + reqName <- newName "req" + helperName <- newName "helper" + + let envE = VarE envName + reqE = VarE reqName + helperE = VarE helperName + + clause404' <- mkClause404 envE reqE + getPathInfo <- mdsGetPathInfo + let pathInfo = getPathInfo `AppE` reqE + + let sdc = SDC + { clause404 = clause404' + , extraParams = [] + , extraCons = [] + , envExp = envE + , reqExp = reqE + } + clauses <- mapM (go sdc) resources + + return $ Clause + [VarP envName, VarP reqName] + (NormalB $ helperE `AppE` pathInfo) + [FunD helperName $ clauses ++ [clause404']] where - go (FlatResource _ name pieces dispatch) = do - let env = VarE $ mkName "env" - req = VarE $ mkName "req" - gpi <- mdsGetPathInfo - gm <- mdsMethod - let handlePiece (_, Static str) = return (LitP $ StringL str, Nothing) - handlePiece (_, Dynamic _) = do - x <- newName "x" - let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) - return (pat, Just x) - pairs <- mapM handlePiece pieces - let pats = map fst pairs - names = mapMaybe snd pairs - runHandler <- mdsRunHandler - let route = foldl' AppE (ConE (mkName name)) (map VarE names) - exp <- case dispatch of - Methods _ [] -> error "no methods" - Methods _ methods -> do - matches <- forM methods $ \method -> do - handler' <- mdsGetHandler (Just method) name - let handler = foldl' AppE handler' (map VarE names) - let body = NormalB exp - jroute = ConE 'Just `AppE` route - exp = runHandler `AppE` handler `AppE` env `AppE` jroute `AppE` req - return $ Match (LitP $ StringL method) body [] - let method = SigE (gm `AppE` req) (ConT ''ByteString) - return $ CaseE method matches - return $ Clause - [ VarP $ mkName "env" - , AsP (mkName "req") (ViewP gpi (ListP pats)) - ] (NormalB exp) [] + handlePiece :: (CheckOverlap, Piece a) -> Q (Pat, Maybe Exp) + handlePiece (_, Static str) = return (LitP $ StringL str, Nothing) + handlePiece (_, Dynamic _) = do + x <- newName "dyn" + let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + return (pat, Just $ VarE x) - mkClause404 = do + handlePieces :: [(CheckOverlap, Piece a)] -> Q ([Pat], [Exp]) + handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece + + mkCon :: String -> [Exp] -> Exp + mkCon name = foldl' AppE (ConE $ mkName name) + + mkPathPat :: Pat -> [Pat] -> Pat + mkPathPat final = + foldr addPat final + where + addPat x y = ConP '(:) [x, y] + + go :: SDC -> ResourceTree a -> Q Clause + go sdc (ResourceParent name pieces children) = do + (pats, dyns) <- handlePieces pieces + let sdc' = sdc + { extraParams = extraParams sdc ++ dyns + , extraCons = extraCons sdc ++ [mkCon name dyns] + } + childClauses <- mapM (go sdc') children + + restName <- newName "rest" + let restE = VarE restName + restP = VarP restName + + helperName <- newName "helper" + let helperE = VarE helperName + + return $ Clause + [mkPathPat restP pats] + (NormalB $ helperE `AppE` restE) + [FunD helperName $ childClauses ++ [clause404 sdc]] + go SDC {..} (ResourceLeaf (Resource name pieces dispatch _)) = do + (pats, dyns) <- handlePieces pieces + + (chooseMethod, finalPat) <- handleDispatch dispatch dyns + + return $ Clause + [mkPathPat finalPat pats] + (NormalB chooseMethod) + [] + where + handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) + handleDispatch dispatch dyns = + case dispatch of + Methods multi methods -> do + (finalPat, mfinalE) <- + case multi of + Nothing -> return (ConP '[] [], Nothing) + Just _ -> do + multiName <- newName "multi" + let pat = ViewP (VarE 'fromPathMultiPiece) + (ConP 'Just [VarP multiName]) + return (pat, Just $ VarE multiName) + + let dynsMulti = + case mfinalE of + Nothing -> dyns + Just e -> dyns ++ [e] + route' = foldl' AppE (ConE (mkName name)) dynsMulti + route = foldr AppE route' extraCons + jroute = ConE 'Just `AppE` route + allDyns = extraParams ++ dynsMulti + mkRunExp mmethod = do + runHandlerE <- mdsRunHandler + handlerE' <- mdsGetHandler mmethod name + let handlerE = foldl' AppE handlerE' allDyns + return $ runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + + func <- + case methods of + [] -> mkRunExp Nothing + _ -> do + getMethod <- mdsMethod + let methodE = getMethod `AppE` reqExp + matches <- forM methods $ \method -> do + exp <- mkRunExp (Just method) + return $ Match (LitP $ StringL method) (NormalB exp) [] + match405 <- do + runHandlerE <- mdsRunHandler + handlerE <- mds405 + let exp = runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + return $ Match WildP (NormalB exp) [] + return $ CaseE methodE $ matches ++ [match405] + + return (func, finalPat) + Subsite _ getSub -> do + restPath <- newName "restPath" + setPathInfoE <- mdsSetPathInfo + subDispatcherE <- mdsSubDispatcher + runHandlerE <- mdsRunHandler + sub <- newName "sub" + let sub2 = LamE [VarP sub] + (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns) + let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp + route' = foldl' AppE (ConE (mkName name)) dyns + route = foldr AppE route' extraCons + getEnv = LitE $ StringL "FIXME2" + exp = subDispatcherE + `AppE` runHandlerE + `AppE` sub2 + `AppE` route + `AppE` envExp + `AppE` reqExp' + return (exp, VarP restPath) + + mkClause404 envE reqE = do handler <- mds404 runHandler <- mdsRunHandler - let exp = runHandler `AppE` handler `AppE` VarE (mkName "env") `AppE` ConE 'Nothing `AppE` VarE (mkName "req") - return $ Clause - [ VarP (mkName "env") - , VarP (mkName "req") - ] (NormalB exp) [] + let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE + return $ Clause [WildP] (NormalB exp) [] diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index 93eb15db..9ac10f55 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/yesod-routes/test/Hierarchy.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Hierarchy ( hierarchy , Dispatcher (..) @@ -113,9 +114,9 @@ do rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources #if SIMPLE_DISPATCH - dispatch <- mkSimpleDispatchClauses MkDispatchSettings + dispatch <- mkSimpleDispatchClause MkDispatchSettings #else - dispatch <- fmap return $ mkDispatchClause MkDispatchSettings + dispatch <- mkDispatchClause MkDispatchSettings #endif { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch|] @@ -132,7 +133,7 @@ do (ConT ''Dispatcher `AppT` ConT ''Hierarchy `AppT` ConT ''Hierarchy) - [FunD (mkName "dispatcher") dispatch] + [FunD (mkName "dispatcher") [dispatch]] : prinst : rrinst diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index afcceb90..b51dd8fc 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -10,6 +10,8 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -ddump-splices #-} import Test.Hspec import Test.HUnit ((@?=)) import Data.Text (Text, pack, unpack, singleton) @@ -129,9 +131,9 @@ do rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress prinst <- mkParseRouteInstance (ConT ''MyApp) ress #if SIMPLE_DISPATCH - dispatch <- mkSimpleDispatchClauses MkDispatchSettings + dispatch <- mkSimpleDispatchClause MkDispatchSettings #else - dispatch <- fmap return $ mkDispatchClause MkDispatchSettings + dispatch <- mkDispatchClause MkDispatchSettings #endif { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch dispatcher|] @@ -148,7 +150,7 @@ do (ConT ''Dispatcher `AppT` ConT ''MyApp `AppT` ConT ''MyApp) - [FunD (mkName "dispatcher") dispatch] + [FunD (mkName "dispatcher") [dispatch]] : prinst : rainst : rrinst