Hierarchy dispatching

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

@@ -17,15 +17,15 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Control.Applicative ((<$>))
 import Data.List (foldl')
 
-data FlatResource a = FlatResource ([String] -> [String]) String [(CheckOverlap, Piece a)] (Dispatch a)
+data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
 
 flatten :: [ResourceTree a] -> [FlatResource a]
 flatten =
-    concatMap (go id id)
+    concatMap (go id)
   where
-    go front1 front2 (ResourceLeaf (Resource a b c)) = [FlatResource front1 a (front2 b) c]
+    go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]
-    go front1 front2 (ResourceParent name pieces children) =
+    go front (ResourceParent name pieces children) =
-        concatMap (go (front1 . (name:)) (front2 . (pieces++))) children
+        concatMap (go (front . ((name, pieces):))) children
 
 -- |
 --
@@ -151,13 +151,14 @@ buildMethodMap :: Q Exp -- ^ fixHandler
                -> FlatResource a
                -> Q (Maybe Dec)
 buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
-buildMethodMap fixHandler (FlatResource names name pieces (Methods mmulti methods)) = do
+buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do
     fromList <- [|Map.fromList|]
     methods' <- mapM go methods
     let exp = fromList `AppE` ListE methods'
     let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
     return $ Just fun
   where
+    pieces = concat $ map snd parents ++ [pieces']
     go method = do
         fh <- fixHandler
         let func = VarE $ mkName $ map toLower method ++ name
@@ -172,24 +173,27 @@ buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
 
 -- | Build a single 'D.Route' expression.
 buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
-buildRoute runHandler dispatcher fixHandler (FlatResource names name resPieces resDisp) = do
+buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
     -- First two arguments to D.Route
-    routePieces <- ListE <$> mapM (convertPiece . snd) resPieces
+    routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
     isMulti <-
         case resDisp of
             Methods Nothing _ -> [|False|]
             _ -> [|True|]
 
-    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|]
+    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
+  where
+    allPieces = concat $ map snd parents ++ [resPieces]
 
 routeArg3 :: Q Exp -- ^ runHandler
           -> Q Exp -- ^ dispatcher
           -> Q Exp -- ^ fixHandler
+          -> [(String, [(CheckOverlap, Piece a)])]
           -> String -- ^ name of resource
           -> [Piece a]
           -> Dispatch a
           -> Q Exp
-routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
+routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
     pieces <- newName "pieces"
 
     -- Allocate input piece variables (xs) and variables that have been
@@ -228,7 +232,7 @@ routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
             _ -> return ([], [])
 
     -- The final expression that actually uses the values we've computed
-    caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest'
+    caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
 
     -- Put together all the statements
     just <- [|Just|]
@@ -251,11 +255,12 @@ buildCaller :: Q Exp -- ^ runHandler
             -> Q Exp -- ^ dispatcher
             -> Q Exp -- ^ fixHandler
             -> Name -- ^ xrest
+            -> [(String, [(CheckOverlap, Piece a)])]
             -> String -- ^ name of resource
             -> Dispatch a
             -> [Name] -- ^ ys
             -> Q Exp
-buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
+buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
     master <- newName "master"
     sub <- newName "sub"
     toMaster <- newName "toMaster"
@@ -266,7 +271,7 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
     let pat = map VarP [master, sub, toMaster, app404, handler405, method]
 
     -- Create the route
-    let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
+    let route = routeFromDynamics parents name ys
 
     exp <-
         case resDisp of
@@ -321,3 +326,16 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
 convertPiece :: Piece a -> Q Exp
 convertPiece (Static s) = [|D.Static (pack $(lift s))|]
 convertPiece (Dynamic _) = [|D.Dynamic|]
+
+routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
+                  -> String -- ^ constructor name
+                  -> [Name]
+                  -> Exp
+routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
+routeFromDynamics ((parent, pieces):rest) name ys =
+    foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
+  where
+    (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
+    isDynamic Dynamic{} = True
+    isDynamic _ = False
+    here = map VarE here' ++ [routeFromDynamics rest name ys']

yesod-routes/test/Hierarchy.hs

@@ -1,23 +1,103 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-module Hierarchy (hierarchy) where
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Hierarchy
+    ( hierarchy
+    , Dispatcher (..)
+    , RunHandler (..)
+    , Handler
+    , App
+    , toText
+    ) where
 
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
+import Test.HUnit
 import Yesod.Routes.Parse
 import Yesod.Routes.TH
 import Yesod.Routes.Class
 import Language.Haskell.TH.Syntax
+import qualified Yesod.Routes.Class as YRC
+import Data.Text (Text, pack, append)
+
+class ToText a where
+    toText :: a -> Text
+
+instance ToText Text where toText = id
+instance ToText String where toText = pack
+
+type Handler sub master = Text
+type App sub master = (Text, Maybe (YRC.Route master))
+
+class Dispatcher sub master where
+    dispatcher
+        :: master
+        -> sub
+        -> (YRC.Route sub -> YRC.Route master)
+        -> App sub master -- ^ 404 page
+        -> (YRC.Route sub -> App sub master) -- ^ 405 page
+        -> Text -- ^ method
+        -> [Text]
+        -> App sub master
+
+class RunHandler sub master where
+    runHandler
+        :: Handler sub master
+        -> master
+        -> sub
+        -> Maybe (YRC.Route sub)
+        -> (YRC.Route sub -> YRC.Route master)
+        -> App sub master
 
 data Hierarchy = Hierarchy
 
-mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) [parseRoutes|
+do
+    let resources = [parseRoutes|
 / HomeR GET
 /admin/#Int AdminR:
     / AdminRootR GET
     /login LoginR GET POST
+    /table/#Text TableR GET
 |]
+    rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
+    dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources
+    return
+        $ InstanceD
+            []
+            (ConT ''Dispatcher
+                `AppT` ConT ''Hierarchy
+                `AppT` ConT ''Hierarchy)
+            [FunD (mkName "dispatcher") [dispatch]]
+        : rrinst
+
+getHomeR :: Handler sub master
+getHomeR = "home"
+
+getAdminRootR :: Int -> Handler sub master
+getAdminRootR i = pack $ "admin root: " ++ show i
+
+getLoginR :: Int -> Handler sub master
+getLoginR i = pack $ "login: " ++ show i
+
+postLoginR :: Int -> Handler sub master
+postLoginR i = pack $ "post login: " ++ show i
+
+getTableR :: Int -> Text -> Handler sub master
+getTableR _ t = append "TableR " t
+
+instance RunHandler Hierarchy master where
+    runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
 
 hierarchy :: Specs
-hierarchy = return ()
+hierarchy = describe "hierarchy" $ do
+    it "renders root correctly" $
+        renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
+    it "renders table correctly" $
+        renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])
+    let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
+    it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)
+    it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")

yesod-routes/test/main.hs

@@ -22,12 +22,6 @@ import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 import Hierarchy
 
-class ToText a where
-    toText :: a -> Text
-
-instance ToText Text where toText = id
-instance ToText String where toText = pack
-
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
 
@@ -102,29 +96,6 @@ instance RenderRoute MySubParam where
 getMySubParam :: MyApp -> Int -> MySubParam
 getMySubParam _ = MySubParam
 
-type Handler sub master = Text
-type App sub master = (Text, Maybe (YRC.Route master))
-
-class Dispatcher sub master where
-    dispatcher
-        :: master
-        -> sub
-        -> (YRC.Route sub -> YRC.Route master)
-        -> App sub master -- ^ 404 page
-        -> (YRC.Route sub -> App sub master) -- ^ 405 page
-        -> Text -- ^ method
-        -> [Text]
-        -> App sub master
-
-class RunHandler sub master where
-    runHandler
-        :: Handler sub master
-        -> master
-        -> sub
-        -> Maybe (YRC.Route sub)
-        -> (YRC.Route sub -> YRC.Route master)
-        -> App sub master
-
 do
     texts <- [t|[Text]|]
     let ress = map ResourceLeaf