-- | Check for overlapping routes.
module Yesod.Routes.Overlap
    ( findOverlapNames
    , Overlap (..)
    ) where

import Yesod.Routes.TH.Types
import Data.List (intercalate)

data Flattened t = Flattened
    { forall t. Flattened t -> [String]
fNames :: [String]
    , forall t. Flattened t -> [Piece t]
fPieces :: [Piece t]
    , forall t. Flattened t -> Bool
fHasSuffix :: Bool
    , forall t. Flattened t -> Bool
fCheck :: CheckOverlap
    }

flatten :: ResourceTree t -> [Flattened t]
flatten :: forall t. ResourceTree t -> [Flattened t]
flatten =
    forall {typ} {t}.
([String] -> [String])
-> ([Piece typ] -> [Piece t])
-> Bool
-> ResourceTree typ
-> [Flattened t]
go forall a. a -> a
id forall a. a -> a
id Bool
True
  where
    go :: ([String] -> [String])
-> ([Piece typ] -> [Piece t])
-> Bool
-> ResourceTree typ
-> [Flattened t]
go [String] -> [String]
names [Piece typ] -> [Piece t]
pieces Bool
check (ResourceLeaf Resource typ
r) = forall (m :: * -> *) a. Monad m => a -> m a
return Flattened
        { fNames :: [String]
fNames = [String] -> [String]
names [forall typ. Resource typ -> String
resourceName Resource typ
r]
        , fPieces :: [Piece t]
fPieces = [Piece typ] -> [Piece t]
pieces (forall typ. Resource typ -> [Piece typ]
resourcePieces Resource typ
r)
        , fHasSuffix :: Bool
fHasSuffix = forall t. ResourceTree t -> Bool
hasSuffix forall a b. (a -> b) -> a -> b
$ forall typ. Resource typ -> ResourceTree typ
ResourceLeaf Resource typ
r
        , fCheck :: Bool
fCheck = Bool
check Bool -> Bool -> Bool
&& forall typ. Resource typ -> Bool
resourceCheck Resource typ
r
        }
    go [String] -> [String]
names [Piece typ] -> [Piece t]
pieces Bool
check (ResourceParent String
newname Bool
check' [Piece typ]
newpieces [ResourceTree typ]
children) =
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([String] -> [String])
-> ([Piece typ] -> [Piece t])
-> Bool
-> ResourceTree typ
-> [Flattened t]
go [String] -> [String]
names' [Piece typ] -> [Piece t]
pieces' (Bool
check Bool -> Bool -> Bool
&& Bool
check')) [ResourceTree typ]
children
      where
        names' :: [String] -> [String]
names' = [String] -> [String]
names forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
newnameforall a. a -> [a] -> [a]
:)
        pieces' :: [Piece typ] -> [Piece t]
pieces' = [Piece typ] -> [Piece t]
pieces forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Piece typ]
newpieces forall a. [a] -> [a] -> [a]
++)

data Overlap t = Overlap
    { forall t. Overlap t -> [String] -> [String]
overlapParents :: [String] -> [String] -- ^ parent resource trees
    , forall t. Overlap t -> ResourceTree t
overlap1 :: ResourceTree t
    , forall t. Overlap t -> ResourceTree t
overlap2 :: ResourceTree t
    }

data OverlapF = OverlapF
    { OverlapF -> [String]
_overlapF1 :: [String]
    , OverlapF -> [String]
_overlapF2 :: [String]
    }

overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool

-- No pieces on either side, will overlap regardless of suffix
overlaps :: forall t. [Piece t] -> [Piece t] -> Bool -> Bool -> Bool
overlaps [] [] Bool
_ Bool
_ = Bool
True

-- No pieces on the left, will overlap if the left side has a suffix
overlaps [] [Piece t]
_ Bool
suffixX Bool
_ = Bool
suffixX

-- Ditto for the right
overlaps [Piece t]
_ [] Bool
_ Bool
suffixY = Bool
suffixY

-- Compare the actual pieces
overlaps (Piece t
pieceX:[Piece t]
xs) (Piece t
pieceY:[Piece t]
ys) Bool
suffixX Bool
suffixY =
    forall t. Piece t -> Piece t -> Bool
piecesOverlap Piece t
pieceX Piece t
pieceY Bool -> Bool -> Bool
&& forall t. [Piece t] -> [Piece t] -> Bool -> Bool -> Bool
overlaps [Piece t]
xs [Piece t]
ys Bool
suffixX Bool
suffixY

piecesOverlap :: Piece t -> Piece t -> Bool
-- Statics only match if they equal. Dynamics match with anything
piecesOverlap :: forall t. Piece t -> Piece t -> Bool
piecesOverlap (Static String
x) (Static String
y) = String
x forall a. Eq a => a -> a -> Bool
== String
y
piecesOverlap Piece t
_ Piece t
_ = Bool
True

findOverlapNames :: [ResourceTree t] -> [(String, String)]
findOverlapNames :: forall t. [ResourceTree t] -> [(String, String)]
findOverlapNames =
    forall a b. (a -> b) -> [a] -> [b]
map OverlapF -> (String, String)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. [Flattened t] -> [OverlapF]
findOverlapsF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall t. Flattened t -> Bool
fCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall t. ResourceTree t -> [Flattened t]
Yesod.Routes.Overlap.flatten
  where
    go :: OverlapF -> (String, String)
go (OverlapF [String]
x [String]
y) =
        ([String] -> String
go' [String]
x, [String] -> String
go' [String]
y)
      where
        go' :: [String] -> String
go' = forall a. [a] -> [[a]] -> [a]
intercalate String
"/"

findOverlapsF :: [Flattened t] -> [OverlapF]
findOverlapsF :: forall t. [Flattened t] -> [OverlapF]
findOverlapsF [] = []
findOverlapsF (Flattened t
x:[Flattened t]
xs) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall t. Flattened t -> Flattened t -> [OverlapF]
findOverlapF Flattened t
x) [Flattened t]
xs forall a. [a] -> [a] -> [a]
++ forall t. [Flattened t] -> [OverlapF]
findOverlapsF [Flattened t]
xs

findOverlapF :: Flattened t -> Flattened t -> [OverlapF]
findOverlapF :: forall t. Flattened t -> Flattened t -> [OverlapF]
findOverlapF Flattened t
x Flattened t
y
    | forall t. [Piece t] -> [Piece t] -> Bool -> Bool -> Bool
overlaps (forall t. Flattened t -> [Piece t]
fPieces Flattened t
x) (forall t. Flattened t -> [Piece t]
fPieces Flattened t
y) (forall t. Flattened t -> Bool
fHasSuffix Flattened t
x) (forall t. Flattened t -> Bool
fHasSuffix Flattened t
y) = [[String] -> [String] -> OverlapF
OverlapF (forall t. Flattened t -> [String]
fNames Flattened t
x) (forall t. Flattened t -> [String]
fNames Flattened t
y)]
    | Bool
otherwise = []

hasSuffix :: ResourceTree t -> Bool
hasSuffix :: forall t. ResourceTree t -> Bool
hasSuffix (ResourceLeaf Resource t
r) =
    case forall typ. Resource typ -> Dispatch typ
resourceDispatch Resource t
r of
        Subsite{} -> Bool
True
        Methods Just{} [String]
_ -> Bool
True
        Methods Maybe t
Nothing [String]
_ -> Bool
False
hasSuffix ResourceParent{} = Bool
True