Dispatching works! (w00t)

yesod-routes/Yesod/Routes/TH/Dispatch.hs

@@ -4,17 +4,16 @@ module Yesod.Routes.TH.Dispatch
       mkDispatchClause
     ) where
 
+import Prelude hiding (exp)
 import Yesod.Routes.TH.Types
 import Language.Haskell.TH.Syntax
-import Data.Maybe (maybeToList, catMaybes)
+import Data.Maybe (catMaybes)
-import Control.Monad (replicateM, forM)
+import Control.Monad (forM)
 import Data.Text (pack)
 import qualified Yesod.Routes.Dispatch as D
 import qualified Data.Map as Map
 import Data.Char (toLower)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
-import Yesod.Routes.Class
-import Data.Maybe (catMaybes)
 import Control.Applicative ((<$>))
 import Data.List (foldl')
 
@@ -60,6 +59,10 @@ mkDispatchClause runHandler dispatcher ress = do
     u <- [|case $(return dispatched) of
             Just f -> f $(return $ VarE master0)
                         $(return $ VarE sub0)
+                        $(return $ VarE toMaster0)
+                        $(return $ VarE app4040)
+                        $(return $ VarE handler4050)
+                        $(return $ VarE method0)
             Nothing -> $(return $ VarE app4040)
           |]
     return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
@@ -95,6 +98,12 @@ buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
 
     [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|]
 
+routeArg3 :: Q Exp -- ^ runHandler
+          -> Q Exp -- ^ dispatcher
+          -> String -- ^ name of resource
+          -> [Piece]
+          -> Dispatch
+          -> Q Exp
 routeArg3 runHandler dispatcher name resPieces resDisp = do
     pieces <- newName "pieces"
 
@@ -134,7 +143,7 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
             _ -> return ([], [])
 
     -- The final expression that actually uses the values we've computed
-    caller <- buildCaller runHandler dispatcher name resDisp $ map snd ys ++ yrest'
+    caller <- buildCaller runHandler dispatcher xrest name resDisp $ map snd ys ++ yrest'
 
     -- Put together all the statements
     just <- [|Just|]
@@ -153,13 +162,20 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
     return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
 
 -- | The final expression in the individual Route definitions.
-buildCaller runHandler dispatcher name resDisp ys = do
+buildCaller :: Q Exp -- ^ runHandler
+            -> Q Exp -- ^ dispatcher
+            -> Name -- ^ xrest
+            -> String -- ^ name of resource
+            -> Dispatch
+            -> [Name] -- ^ ys
+            -> Q Exp
+buildCaller runHandler dispatcher xrest name resDisp ys = do
     master <- newName "master"
     sub <- newName "sub"
     toMaster <- newName "toMaster"
-    app404 <- newName "app404"
+    app404 <- newName "_app404"
-    handler405 <- newName "handler405"
+    handler405 <- newName "_handler405"
-    method <- newName "method"
+    method <- newName "_method"
 
     let pat = map VarP [master, sub, toMaster, app404, handler405, method]
 
@@ -202,6 +218,7 @@ buildCaller runHandler dispatcher name resDisp ys = do
                     $(return $ VarE app404)
                     $(return $ VarE handler405)
                     $(return $ VarE method)
+                    $(return $ VarE xrest)
                  |]
 
     return $ LamE pat exp

yesod-routes/test/main.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
@@ -17,7 +19,6 @@ import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
 
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
@@ -81,25 +82,28 @@ instance RenderRoute MySubParam where
 getMySubParam :: MyApp -> Int -> MySubParam
 getMySubParam _ = MySubParam
 
-class Dispatcher handler master sub app where
+type Handler sub master = String
+type App sub master = (String, Maybe (YRC.Route master))
+
+class Dispatcher sub master where
     dispatcher
         :: master
         -> sub
         -> (YRC.Route sub -> YRC.Route master)
-        -> app -- ^ 404 page
+        -> App sub master -- ^ 404 page
-        -> handler -- ^ 405 page
+        -> Handler sub master -- ^ 405 page
         -> Text -- ^ method
         -> [Text]
-        -> app
+        -> App sub master
 
-class RunHandler handler master sub app where
+class RunHandler sub master where
     runHandler
-        :: handler
+        :: Handler sub master
         -> master
         -> sub
         -> YRC.Route sub
         -> (YRC.Route sub -> YRC.Route master)
-        -> app
+        -> App sub master
 
 do
     texts <- [t|[Text]|]
@@ -114,20 +118,21 @@ do
     dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress
     return
         [ rrinst
-        , FunD (mkName "thDispatch") [dispatch]
+        , InstanceD
+            []
+            (ConT ''Dispatcher
+                `AppT` ConT ''MyApp
+                `AppT` ConT ''MyApp)
+            [FunD (mkName "dispatcher") [dispatch]]
         ]
 
-instance Dispatcher [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
+instance RunHandler MyApp master where
-    dispatcher = thDispatchAlias
-    --dispatcher = thDispatch
-
-instance RunHandler [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
     runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
 
-instance Dispatcher [Char] master MySub ([Char], Maybe (YRC.Route master)) where
+instance Dispatcher MySub master where
     dispatcher _ _ toMaster _ _ _ pieces = ("subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
 
-instance Dispatcher [Char] master MySubParam ([Char], Maybe (YRC.Route master)) where
+instance Dispatcher MySubParam master where
     dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
         case map unpack pieces of
             [[c]] -> ("subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
@@ -153,7 +158,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
         [ Route [] False $ \pieces ->
             case pieces of
                 [] -> do
-                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' _app404' handler405' method ->
                         let handler =
                                 case Map.lookup method methodsRootR of
                                     Just f -> f
@@ -164,7 +169,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
             case pieces of
                 [_, x2] -> do
                     y2 <- fromPathPiece x2
-                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' _app404' handler405' method ->
                         let handler =
                                 case Map.lookup method methodsBlogPostR of
                                     Just f -> f y2
@@ -175,7 +180,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
             case pieces of
                 _:x2 -> do
                     y2 <- fromPathMultiPiece x2
-                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' _app404' _handler405' _method ->
                         let handler = handleWikiR y2
                          in runHandler handler master' sub' (WikiR y2) toMaster'
                 _ -> error "Invariant violated"
@@ -235,7 +240,7 @@ main = hspecX $ do
             @?= (["subparam", "6", "c"], [])
 
     describe "thDispatch" $ do
-        let disp = thDispatchAlias MyApp MyApp id ("404", Nothing) "405"
+        let disp = dispatcher MyApp MyApp id ("404" :: String, Nothing) "405"
         it "routes to root" $ disp "GET" [] @?= ("this is the root", Just RootR)
         it "POST root is 405" $ disp "POST" [] @?= ("405", Just RootR)
         it "invalid page is a 404" $ disp "GET" ["not-found"] @?= ("404", Nothing)