module Yesod.Routes.Overlap
( findOverlaps
, findOverlapNames
, Overlap (..)
) where
import Yesod.Routes.TH.Types
import Data.List (intercalate)
data Overlap t = Overlap
{ overlapParents :: [String] -> [String]
, overlap1 :: ResourceTree t
, overlap2 :: ResourceTree t
}
findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
findOverlaps _ [] = []
findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
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
overlaps [] [] _ _ = True
overlaps [] _ suffixX _ = suffixX
overlaps _ [] _ suffixY = suffixY
overlaps ((False, _):_) _ _ _ = False
overlaps _ ((False, _):_) _ _ = False
overlaps ((True, pieceX):xs) ((True, pieceY):ys) suffixX suffixY =
piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY
piecesOverlap :: Piece t -> Piece t -> Bool
piecesOverlap (Static x) (Static y) = x == y
piecesOverlap _ _ = True
findOverlapNames :: [ResourceTree t] -> [(String, String)]
findOverlapNames =
map go . findOverlaps id
where
go (Overlap front x y) =
(go' $ resourceTreeName x, go' $ resourceTreeName y)
where
go' = intercalate "/" . front . return