69 lines
2.3 KiB
Haskell
69 lines
2.3 KiB
Haskell
-- | Check for overlapping routes.
|
|
module Yesod.Routes.Overlap
|
|
( findOverlaps
|
|
, findOverlapNames
|
|
) where
|
|
|
|
import Yesod.Routes.TH.Types
|
|
import Control.Arrow ((***))
|
|
import Data.Maybe (mapMaybe)
|
|
|
|
findOverlaps :: [Resource t] -> [(Resource t, Resource t)]
|
|
findOverlaps [] = []
|
|
findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs
|
|
|
|
findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t)
|
|
findOverlap x y
|
|
| overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y)
|
|
| otherwise = Nothing
|
|
|
|
hasSuffix :: Resource t -> Bool
|
|
hasSuffix r =
|
|
case resourceDispatch r of
|
|
Subsite{} -> True
|
|
Methods Just{} _ -> True
|
|
Methods Nothing _ -> False
|
|
|
|
overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
|
|
overlaps [] [] False False = False
|
|
overlaps [] _ suffixX _ = suffixX
|
|
overlaps _ [] _ suffixY = suffixY
|
|
overlaps ((False, _):xs) (_:ys) suffixX suffixY = overlaps xs ys suffixX suffixY
|
|
overlaps (_:xs) ((False, _):ys) suffixX suffixY = overlaps xs ys suffixX suffixY
|
|
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 :: [Resource t] -> [(String, String)]
|
|
findOverlapNames = map (resourceName *** resourceName) . findOverlaps
|
|
|
|
{-
|
|
-- n^2, should be a way to speed it up
|
|
findOverlaps :: [Resource a] -> [[Resource a]]
|
|
findOverlaps = go . map justPieces
|
|
where
|
|
justPieces :: Resource a -> ([Piece a], Resource a)
|
|
justPieces r@(Resource _ ps _) = (ps, r)
|
|
|
|
go [] = []
|
|
go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
|
|
|
|
mOverlap :: ([Piece a], Resource a) -> ([Piece a], Resource a) ->
|
|
Maybe [Resource a]
|
|
mOverlap _ _ = Nothing
|
|
{- FIXME mOverlap
|
|
mOverlap (Static x:xs, xr) (Static y:ys, yr)
|
|
| x == y = mOverlap (xs, xr) (ys, yr)
|
|
| otherwise = Nothing
|
|
mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
|
|
mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
|
|
mOverlap ([], xr) ([], yr) = Just (xr, yr)
|
|
mOverlap ([], _) (_, _) = Nothing
|
|
mOverlap (_, _) ([], _) = Nothing
|
|
mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)
|
|
-}
|
|
-}
|