Beginning of hierarchichal routes, not done

yesod-routes/Yesod/Routes/Overlap.hs

@@ -2,27 +2,41 @@
 module Yesod.Routes.Overlap
     ( findOverlaps
     , findOverlapNames
+    , Overlap (..)
     ) where
 
 import Yesod.Routes.TH.Types
-import Control.Arrow ((***))
+import Data.List (intercalate)
-import Data.Maybe (mapMaybe)
 
-findOverlaps :: [Resource t] -> [(Resource t, Resource t)]
+data Overlap t = Overlap
-findOverlaps [] = []
+    { overlapParents :: [String] -> [String] -- ^ parent resource trees
-findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs
+    , overlap1 :: ResourceTree t
+    , overlap2 :: ResourceTree t
+    }
 
-findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t)
+findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
-findOverlap x y
+findOverlaps _ [] = []
-    | overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y)
+findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
-    | otherwise = Nothing
 
-hasSuffix :: Resource t -> Bool
+findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
-hasSuffix r =
+findOverlap front x y =
+    here rest
+  where
+    here
+        | overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:)
+        | otherwise = id
+    rest =
+        case x of
+            ResourceParent name _ children -> findOverlaps (front . (name:)) children
+            ResourceLeaf{} -> []
+
+hasSuffix :: ResourceTree t -> Bool
+hasSuffix (ResourceLeaf r) =
     case resourceDispatch r of
         Subsite{} -> True
         Methods Just{} _ -> True
         Methods Nothing _ -> False
+hasSuffix ResourceParent{} = True
 
 overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
 
@@ -50,9 +64,14 @@ piecesOverlap :: Piece t -> Piece t -> Bool
 piecesOverlap (Static x) (Static y) = x == y
 piecesOverlap _ _ = True
 
-findOverlapNames :: [Resource t] -> [(String, String)]
+findOverlapNames :: [ResourceTree t] -> [(String, String)]
-findOverlapNames = map (resourceName *** resourceName) . findOverlaps
+findOverlapNames =
-
+    map go . findOverlaps id
+  where
+    go (Overlap front x y) =
+        (go' $ resourceTreeName x, go' $ resourceTreeName y)
+      where
+        go' = intercalate "/" . front . return
 {-
 -- n^2, should be a way to speed it up
 findOverlaps :: [Resource a] -> [[Resource a]]

yesod-routes/Yesod/Routes/Parse.hs

@@ -10,7 +10,6 @@ module Yesod.Routes.Parse
     ) where
 
 import Language.Haskell.TH.Syntax
-import Data.Maybe
 import Data.Char (isUpper)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
@@ -55,18 +54,29 @@ parseRoutesNoCheck = QuasiQuoter
 -- | Convert a multi-line string to a set of resources. See documentation for
 -- the format of this string. This is a partial function which calls 'error' on
 -- invalid input.
-resourcesFromString :: String -> [Resource String]
+resourcesFromString :: String -> [ResourceTree String]
 resourcesFromString =
-    mapMaybe go . lines
+    fst . parse 0 . lines
   where
-    go s =
+    parse _ [] = ([], [])
-        case takeWhile (/= "--") $ words s of
+    parse indent (thisLine:otherLines)
-            (pattern:constr:rest) ->
+        | length spaces < indent = ([], thisLine : otherLines)
-                let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
+        | otherwise = (this others, remainder)
-                    disp = dispatchFromString rest mmulti
+      where
-                 in Just $ Resource constr pieces disp
+        spaces = takeWhile (== ' ') thisLine
-            [] -> Nothing
+        (others, remainder) = parse indent otherLines'
-            _ -> error $ "Invalid resource line: " ++ s
+        (this, otherLines') =
+            case takeWhile (/= "--") $ words thisLine of
+                [pattern, constr] | last constr == ':' ->
+                    let (children, otherLines'') = parse (length spaces + 1) otherLines
+                        (pieces, Nothing) = piecesFromString $ drop1Slash pattern
+                     in ((ResourceParent (init constr) pieces children :), otherLines'')
+                (pattern:constr:rest) ->
+                    let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
+                        disp = dispatchFromString rest mmulti
+                     in ((ResourceLeaf (Resource constr pieces disp):), otherLines)
+                [] -> (id, otherLines)
+                _ -> error $ "Invalid resource line: " ++ thisLine
 
 dispatchFromString :: [String] -> Maybe String -> Dispatch String
 dispatchFromString rest mmulti

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

@@ -17,6 +17,16 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Control.Applicative ((<$>))
 import Data.List (foldl')
 
+data FlatResource a = FlatResource ([String] -> [String]) String [(CheckOverlap, Piece a)] (Dispatch a)
+
+flatten :: [ResourceTree a] -> [FlatResource a]
+flatten =
+    concatMap (go id id)
+  where
+    go front1 front2 (ResourceLeaf (Resource a b c)) = [FlatResource front1 a (front2 b) c]
+    go front1 front2 (ResourceParent name pieces children) =
+        concatMap (go (front1 . (name:)) (front2 . (pieces++))) children
+
 -- |
 --
 -- This function will generate a single clause that will address all
@@ -83,9 +93,9 @@ import Data.List (foldl')
 mkDispatchClause :: Q Exp -- ^ runHandler function
                  -> Q Exp -- ^ dispatcher function
                  -> Q Exp -- ^ fixHandler function
-                 -> [Resource a]
+                 -> [ResourceTree a]
                  -> Q Clause
-mkDispatchClause runHandler dispatcher fixHandler ress = do
+mkDispatchClause runHandler dispatcher fixHandler ress' = do
     -- Allocate the names to be used. Start off with the names passed to the
     -- function itself (with a 0 suffix).
     --
@@ -130,16 +140,18 @@ mkDispatchClause runHandler dispatcher fixHandler ress = do
             Nothing -> $(return $ VarE app4040)
           |]
     return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
+  where
+    ress = flatten ress'
 
 -- | Determine the name of the method map for a given resource name.
 methodMapName :: String -> Name
 methodMapName s = mkName $ "methods" ++ s
 
 buildMethodMap :: Q Exp -- ^ fixHandler
-               -> Resource a
+               -> FlatResource a
                -> Q (Maybe Dec)
-buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
+buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
-buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
+buildMethodMap fixHandler (FlatResource names name pieces (Methods mmulti methods)) = do
     fromList <- [|Map.fromList|]
     methods' <- mapM go methods
     let exp = fromList `AppE` ListE methods'
@@ -156,11 +168,11 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
         xs <- replicateM argCount $ newName "arg"
         let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
         return $ TupE [pack' `AppE` LitE (StringL method), rhs]
-buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing
+buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
 
 -- | Build a single 'D.Route' expression.
-buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp
+buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
-buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
+buildRoute runHandler dispatcher fixHandler (FlatResource names name resPieces resDisp) = do
     -- First two arguments to D.Route
     routePieces <- ListE <$> mapM (convertPiece . snd) resPieces
     isMulti <-

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

@@ -14,17 +14,19 @@ import Control.Monad (replicateM)
 import Data.Text (pack)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
+import Data.Monoid (mconcat)
 
 -- | Generate the constructors of a route data type.
-mkRouteCons :: [Resource Type] -> [Con]
+mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec])
 mkRouteCons =
-    map mkRouteCon
+    mconcat . map mkRouteCon
   where
-    mkRouteCon res =
+    mkRouteCon (ResourceLeaf res) =
-        NormalC (mkName $ resourceName res)
+        ([con], [])
+      where
+        con = NormalC (mkName $ resourceName res)
             $ map (\x -> (NotStrict, x))
             $ concat [singles, multi, sub]
-      where
         singles = concatMap (toSingle . snd) $ resourcePieces res
         toSingle Static{} = []
         toSingle (Dynamic typ) = [typ]
@@ -35,16 +37,53 @@ mkRouteCons =
             case resourceDispatch res of
                 Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
                 _ -> []
+    mkRouteCon (ResourceParent name pieces children) =
+        ([con], dec : decs)
+      where
+        (cons, decs) = mkRouteCons children
+        con = NormalC (mkName name)
+            $ map (\x -> (NotStrict, x))
+            $ concat [singles, [ConT $ mkName name]]
+        dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
+
+        singles = concatMap (toSingle . snd) pieces
+        toSingle Static{} = []
+        toSingle (Dynamic typ) = [typ]
 
 -- | Clauses for the 'renderRoute' method.
-mkRenderRouteClauses :: [Resource Type] -> Q [Clause]
+mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
 mkRenderRouteClauses =
     mapM go
   where
     isDynamic Dynamic{} = True
     isDynamic _ = False
 
-    go res = do
+    go (ResourceParent name pieces children) = do
+        let cnt = length $ filter (isDynamic . snd) pieces
+        dyns <- replicateM cnt $ newName "dyn"
+        child <- newName "child"
+        let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
+
+        pack' <- [|pack|]
+        tsp <- [|toPathPiece|]
+        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns
+
+        childRender <- newName "childRender"
+        let rr = VarE childRender
+        childClauses <- mkRenderRouteClauses children
+
+        a <- newName "a"
+        b <- newName "b"
+
+        colon <- [|(:)|]
+        let cons y ys = InfixE (Just y) colon (Just ys)
+        let pieces = foldr cons (VarE a) piecesSingle
+
+        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE child)
+
+        return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
+
+    go (ResourceLeaf res) = do
         let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
         dyns <- replicateM cnt $ newName "dyn"
         sub <-
@@ -93,18 +132,19 @@ mkRenderRouteClauses =
 -- This includes both the 'Route' associated type and the
 -- 'renderRoute' method.  This function uses both 'mkRouteCons' and
 -- 'mkRenderRouteClasses'.
-mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec
+mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]
 mkRenderRouteInstance = mkRenderRouteInstance' []
 
 -- | A more general version of 'mkRenderRouteInstance' which takes an
 -- additional context.
 
-mkRenderRouteInstance' :: Cxt -> Type -> [Resource Type] -> Q Dec
+mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
 mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
+    let (cons, decs) = mkRouteCons ress
     return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)
-        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
+        [ DataInstD [] ''Route [typ] cons clazzes
         , FunD (mkName "renderRoute") cls
-        ]
+        ] : decs
   where
     clazzes = [''Show, ''Eq, ''Read]

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

@@ -2,16 +2,37 @@
 module Yesod.Routes.TH.Types
     ( -- * Data types
       Resource (..)
+    , ResourceTree (..)
     , Piece (..)
     , Dispatch (..)
     , CheckOverlap
       -- ** Helper functions
     , resourceMulti
+    , resourceTreePieces
+    , resourceTreeName
     ) where
 
 import Language.Haskell.TH.Syntax
 import Control.Arrow (second)
 
+data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ]
+
+resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)]
+resourceTreePieces (ResourceLeaf r) = resourcePieces r
+resourceTreePieces (ResourceParent _ x _) = x
+
+resourceTreeName :: ResourceTree typ -> String
+resourceTreeName (ResourceLeaf r) = resourceName r
+resourceTreeName (ResourceParent x _ _) = x
+
+instance Functor ResourceTree where
+    fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r)
+    fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c
+
+instance Lift t => Lift (ResourceTree t) where
+    lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
+    lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|]
+
 data Resource typ = Resource
     { resourceName :: String
     , resourcePieces :: [(CheckOverlap, Piece typ)]

yesod-routes/test/Hierarchy.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hierarchy (hierarchy) where
+
+import Test.Hspec.Monadic
+import Test.Hspec.HUnit ()
+import Yesod.Routes.Parse
+import Yesod.Routes.TH
+import Yesod.Routes.Class
+import Language.Haskell.TH.Syntax
+
+data Hierarchy = Hierarchy
+
+mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) [parseRoutes|
+/ HomeR GET
+/admin/#Int AdminR:
+    / AdminRootR GET
+    /login LoginR GET POST
+|]
+
+hierarchy :: Specs
+hierarchy = return ()

yesod-routes/test/main.hs

@@ -20,6 +20,7 @@ import Yesod.Routes.Parse (parseRoutesNoCheck)
 import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
+import Hierarchy
 
 class ToText a where
     toText :: a -> Text
@@ -126,7 +127,7 @@ class RunHandler sub master where
 
 do
     texts <- [t|[Text]|]
-    let ress =
+    let ress = map ResourceLeaf
             [ Resource "RootR" [] $ Methods Nothing ["GET"]
             , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"]
             , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) []
@@ -137,14 +138,13 @@ do
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
     dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
     return
-        [ rrinst
+        $ InstanceD
-        , InstanceD
             []
             (ConT ''Dispatcher
                 `AppT` ConT ''MyApp
                 `AppT` ConT ''MyApp)
             [FunD (mkName "dispatcher") [dispatch]]
-        ]
+        : rrinst
 
 instance RunHandler MyApp master where
     runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
@@ -328,6 +328,7 @@ main = hspecX $ do
 /bar/baz Foo3
 |]
             findOverlapNames routes @?= []
+    hierarchy
 
 getRootR :: Text
 getRootR = pack "this is the root"

yesod-routes/yesod-routes.cabal

@@ -36,6 +36,7 @@ test-suite runtests
     type: exitcode-stdio-1.0
     main-is: main.hs
     hs-source-dirs: test
+    other-modules: Hierarchy
 
     build-depends: base                      >= 4.3      && < 5
                  , yesod-routes