Improved overlap checking for nesting #632

yesod-routes/Yesod/Routes/Overlap.hs

@@ -8,15 +8,42 @@ module Yesod.Routes.Overlap
 import Yesod.Routes.TH.Types
 import Data.List (intercalate)
 
+data Flattened t = Flattened
+    { fNames :: [String]
+    , fPieces :: [(CheckOverlap, Piece t)]
+    , fHasSuffix :: Bool
+    }
+
+flatten :: ResourceTree t -> [Flattened t]
+flatten =
+    go id id
+  where
+    go names pieces (ResourceLeaf r) = return Flattened
+        { fNames = names [resourceName r]
+        , fPieces = pieces (resourcePieces r)
+        , fHasSuffix = hasSuffix $ ResourceLeaf r
+        }
+    go names pieces (ResourceParent newname newpieces children) =
+        concatMap (go names' pieces') children
+      where
+        names' = names . (newname:)
+        pieces' = pieces . (newpieces ++)
+
 data Overlap t = Overlap
     { overlapParents :: [String] -> [String] -- ^ parent resource trees
     , overlap1 :: ResourceTree t
     , overlap2 :: ResourceTree t
     }
 
+data OverlapF = OverlapF
+    { overlapF1 :: [String]
+    , overlapF2 :: [String]
+    }
+
 findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
 findOverlaps _ [] = []
 findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
+{-# DEPRECATED findOverlaps "This function is no longer used" #-}
 
 findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
 findOverlap front x y =
@@ -30,14 +57,6 @@ findOverlap front x y =
             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
 
 -- No pieces on either side, will overlap regardless of suffix
@@ -66,9 +85,26 @@ piecesOverlap _ _ = True
 
 findOverlapNames :: [ResourceTree t] -> [(String, String)]
 findOverlapNames =
-    map go . findOverlaps id
+    map go . findOverlapsF . concatMap Yesod.Routes.Overlap.flatten
   where
-    go (Overlap front x y) =
-        (go' $ resourceTreeName x, go' $ resourceTreeName y)
+    go (OverlapF x y) =
+        (go' x, go' y)
       where
-        go' = intercalate "/" . front . return
+        go' = intercalate "/"
+
+findOverlapsF :: [Flattened t] -> [OverlapF]
+findOverlapsF [] = []
+findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs
+
+findOverlapF :: Flattened t -> Flattened t -> [OverlapF]
+findOverlapF x y
+    | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]
+    | otherwise = []
+
+hasSuffix :: ResourceTree t -> Bool
+hasSuffix (ResourceLeaf r) =
+    case resourceDispatch r of
+        Subsite{} -> True
+        Methods Just{} _ -> True
+        Methods Nothing _ -> False
+hasSuffix ResourceParent{} = True

yesod-routes/Yesod/Routes/Parse.hs

@@ -29,7 +29,7 @@ parseRoutes = QuasiQuoter { quoteExp = x }
         let res = resourcesFromString s
         case findOverlapNames res of
             [] -> lift res
-            z -> error $ "Overlapping routes: " ++ unlines (map show z)
+            z -> error $ unlines $ "Overlapping routes: " : map show z
 
 parseRoutesFile :: FilePath -> Q Exp
 parseRoutesFile = parseRoutesFileWith parseRoutes

yesod-routes/test/Hierarchy.hs

@@ -89,14 +89,18 @@ do
   /nest2 Nest2:
     /get        Get2      GET
     /post       Post2         POST
-    /#Int       Delete2            DELETE
+--    /#Int       Delete2            DELETE
   /nest3 Nest3:
     /get        Get3      GET
     /post       Post3         POST
-    /#Int       Delete3            DELETE
+--    /#Int       Delete3            DELETE
 
 /afterwards AfterR:
   /             After     GET
+
+-- /trailing-nest TrailingNestR:
+--  /foo TrailingFooR GET
+--  /#Int TrailingIntR GET
 |]
 
     rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources