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

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

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

flatten :: ResourceTree t -> [Flattened t]
flatten :: ResourceTree t -> [Flattened t]
flatten =
    ([String] -> [String])
-> ([Piece t] -> [Piece t])
-> Bool
-> ResourceTree t
-> [Flattened t]
forall typ t.
([String] -> [String])
-> ([Piece typ] -> [Piece t])
-> Bool
-> ResourceTree typ
-> [Flattened t]
go [String] -> [String]
forall a. a -> a
id [Piece t] -> [Piece t]
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) = Flattened t -> [Flattened t]
forall (m :: * -> *) a. Monad m => a -> m a
return Flattened :: forall t. [String] -> [Piece t] -> Bool -> Bool -> Flattened t
Flattened
        { fNames :: [String]
fNames = [String] -> [String]
names [Resource typ -> String
forall typ. Resource typ -> String
resourceName Resource typ
r]
        , fPieces :: [Piece t]
fPieces = [Piece typ] -> [Piece t]
pieces (Resource typ -> [Piece typ]
forall typ. Resource typ -> [Piece typ]
resourcePieces Resource typ
r)
        , fHasSuffix :: Bool
fHasSuffix = ResourceTree typ -> Bool
forall t. ResourceTree t -> Bool
hasSuffix (ResourceTree typ -> Bool) -> ResourceTree typ -> Bool
forall a b. (a -> b) -> a -> b
$ Resource typ -> ResourceTree typ
forall typ. Resource typ -> ResourceTree typ
ResourceLeaf Resource typ
r
        , fCheck :: Bool
fCheck = Bool
check Bool -> Bool -> Bool
&& Resource typ -> 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) =
        (ResourceTree typ -> [Flattened t])
-> [ResourceTree typ] -> [Flattened t]
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 ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
newnameString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
        pieces' :: [Piece typ] -> [Piece t]
pieces' = [Piece typ] -> [Piece t]
pieces ([Piece typ] -> [Piece t])
-> ([Piece typ] -> [Piece typ]) -> [Piece typ] -> [Piece t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Piece typ]
newpieces [Piece typ] -> [Piece typ] -> [Piece typ]
forall a. [a] -> [a] -> [a]
++)

data Overlap t = Overlap
    { Overlap t -> [String] -> [String]
overlapParents :: [String] -> [String] -- ^ parent resource trees
    , Overlap t -> ResourceTree t
overlap1 :: ResourceTree 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 :: [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 =
    Piece t -> Piece t -> Bool
forall t. Piece t -> Piece t -> Bool
piecesOverlap Piece t
pieceX Piece t
pieceY Bool -> Bool -> Bool
&& [Piece t] -> [Piece t] -> 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 :: Piece t -> Piece t -> Bool
piecesOverlap (Static String
x) (Static String
y) = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y
piecesOverlap Piece t
_ Piece t
_ = Bool
True

findOverlapNames :: [ResourceTree t] -> [(String, String)]
findOverlapNames :: [ResourceTree t] -> [(String, String)]
findOverlapNames =
    (OverlapF -> (String, String)) -> [OverlapF] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map OverlapF -> (String, String)
go ([OverlapF] -> [(String, String)])
-> ([ResourceTree t] -> [OverlapF])
-> [ResourceTree t]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Flattened t] -> [OverlapF]
forall t. [Flattened t] -> [OverlapF]
findOverlapsF ([Flattened t] -> [OverlapF])
-> ([ResourceTree t] -> [Flattened t])
-> [ResourceTree t]
-> [OverlapF]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flattened t -> Bool) -> [Flattened t] -> [Flattened t]
forall a. (a -> Bool) -> [a] -> [a]
filter Flattened t -> Bool
forall t. Flattened t -> Bool
fCheck ([Flattened t] -> [Flattened t])
-> ([ResourceTree t] -> [Flattened t])
-> [ResourceTree t]
-> [Flattened t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResourceTree t -> [Flattened t])
-> [ResourceTree t] -> [Flattened t]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ResourceTree t -> [Flattened t]
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' = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/"

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

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

hasSuffix :: ResourceTree t -> Bool
hasSuffix :: ResourceTree t -> Bool
hasSuffix (ResourceLeaf Resource t
r) =
    case Resource t -> Dispatch t
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