All simpler dispatch tests pass

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]
+data SDC = SDC
-mkSimpleDispatchClauses MkDispatchSettings {..} (flatten -> resources) = do
+    { clause404 :: Clause
-    clauses <- mapM go resources
+    , extraParams :: [Exp]
-    clause404 <- mkClause404
+    , extraCons :: [Exp]
-    return $ clauses ++ [clause404]
+    , 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
+    handlePiece :: (CheckOverlap, Piece a) -> Q (Pat, Maybe Exp)
-        let env = VarE $ mkName "env"
+    handlePiece (_, Static str) = return (LitP $ StringL str, Nothing)
-            req = VarE $ mkName "req"
+    handlePiece (_, Dynamic _) = do
-        gpi <- mdsGetPathInfo
+        x <- newName "dyn"
-        gm <- mdsMethod
+        let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
-        let handlePiece (_, Static str) = return (LitP $ StringL str, Nothing)
+        return (pat, Just $ VarE x)
-            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) []
 
-    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")
+        let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE
-        return $ Clause
+        return $ Clause [WildP] (NormalB exp) []
-            [ VarP (mkName "env")
-            , VarP (mkName "req")
-            ] (NormalB exp) []

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
 

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