Better overlap rules #779
We now have the concept that either an entire route is overlap checked or not. This is essentially what we had before, except there was code littered everywhere on the mistaken assumption that just one component could be overlap checked. This also allows us to mark parent routes or multipiece components as non-overlapped checked. In addition, if you put a bang at the beginning of the pattern, the entire route is not overlap checked. The previous syntax is kept for backwards compatibility.
This commit is contained in:
Michael Snoyman
parent
21d1965774
commit
e23c78f2ce
@ -1,7 +1,6 @@
|
||||
-- | Check for overlapping routes.
|
||||
module Yesod.Routes.Overlap
|
||||
( findOverlaps
|
||||
, findOverlapNames
|
||||
( findOverlapNames
|
||||
, Overlap (..)
|
||||
) where
|
||||
|
||||
@ -10,21 +9,23 @@ import Data.List (intercalate)
|
||||
|
||||
data Flattened t = Flattened
|
||||
{ fNames :: [String]
|
||||
, fPieces :: [(CheckOverlap, Piece t)]
|
||||
, fPieces :: [Piece t]
|
||||
, fHasSuffix :: Bool
|
||||
, fCheck :: CheckOverlap
|
||||
}
|
||||
|
||||
flatten :: ResourceTree t -> [Flattened t]
|
||||
flatten =
|
||||
go id id
|
||||
go id id True
|
||||
where
|
||||
go names pieces (ResourceLeaf r) = return Flattened
|
||||
go names pieces check (ResourceLeaf r) = return Flattened
|
||||
{ fNames = names [resourceName r]
|
||||
, fPieces = pieces (resourcePieces r)
|
||||
, fHasSuffix = hasSuffix $ ResourceLeaf r
|
||||
, fCheck = check && resourceCheck r
|
||||
}
|
||||
go names pieces (ResourceParent newname newpieces children) =
|
||||
concatMap (go names' pieces') children
|
||||
go names pieces check (ResourceParent newname check' newpieces children) =
|
||||
concatMap (go names' pieces' (check && check')) children
|
||||
where
|
||||
names' = names . (newname:)
|
||||
pieces' = pieces . (newpieces ++)
|
||||
@ -40,24 +41,7 @@ data OverlapF = OverlapF
|
||||
, 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 =
|
||||
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{} -> []
|
||||
|
||||
overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
|
||||
overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool
|
||||
|
||||
-- No pieces on either side, will overlap regardless of suffix
|
||||
overlaps [] [] _ _ = True
|
||||
@ -68,14 +52,8 @@ overlaps [] _ suffixX _ = suffixX
|
||||
-- Ditto for the right
|
||||
overlaps _ [] _ suffixY = suffixY
|
||||
|
||||
-- As soon as we ignore a single piece (via CheckOverlap == False), we say that
|
||||
-- the routes don't overlap at all. In other words, disabling overlap checking
|
||||
-- on a single piece disables it on the whole route.
|
||||
overlaps ((False, _):_) _ _ _ = False
|
||||
overlaps _ ((False, _):_) _ _ = False
|
||||
|
||||
-- Compare the actual pieces
|
||||
overlaps ((True, pieceX):xs) ((True, pieceY):ys) suffixX suffixY =
|
||||
overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY =
|
||||
piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY
|
||||
|
||||
piecesOverlap :: Piece t -> Piece t -> Bool
|
||||
@ -85,7 +63,7 @@ piecesOverlap _ _ = True
|
||||
|
||||
findOverlapNames :: [ResourceTree t] -> [(String, String)]
|
||||
findOverlapNames =
|
||||
map go . findOverlapsF . concatMap Yesod.Routes.Overlap.flatten
|
||||
map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten
|
||||
where
|
||||
go (OverlapF x y) =
|
||||
(go' x, go' y)
|
||||
|
||||
@ -73,16 +73,29 @@ resourcesFromString =
|
||||
case takeWhile (/= "--") $ words thisLine of
|
||||
[pattern, constr] | last constr == ':' ->
|
||||
let (children, otherLines'') = parse (length spaces + 1) otherLines
|
||||
(pieces, Nothing) = piecesFromString $ drop1Slash pattern
|
||||
in ((ResourceParent (init constr) pieces children :), otherLines'')
|
||||
(pieces, Nothing, check) = piecesFromStringCheck pattern
|
||||
in ((ResourceParent (init constr) check pieces children :), otherLines'')
|
||||
(pattern:constr:rest) ->
|
||||
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
|
||||
let (pieces, mmulti, check) = piecesFromStringCheck pattern
|
||||
(attrs, rest') = takeAttrs rest
|
||||
disp = dispatchFromString rest' mmulti
|
||||
in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines)
|
||||
in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)
|
||||
[] -> (id, otherLines)
|
||||
_ -> error $ "Invalid resource line: " ++ thisLine
|
||||
|
||||
piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)
|
||||
piecesFromStringCheck s0 =
|
||||
(pieces, mmulti, check)
|
||||
where
|
||||
(s1, check1) = stripBang s0
|
||||
(pieces', mmulti') = piecesFromString $ drop1Slash s1
|
||||
pieces = map snd pieces'
|
||||
mmulti = fmap snd mmulti'
|
||||
check = check1 && all fst pieces' && maybe True fst mmulti'
|
||||
|
||||
stripBang ('!':rest) = (rest, False)
|
||||
stripBang x = (x, True)
|
||||
|
||||
-- | Take attributes out of the list and put them in the first slot in the
|
||||
-- result tuple.
|
||||
takeAttrs :: [String] -> ([String], [String])
|
||||
@ -107,7 +120,7 @@ drop1Slash :: String -> String
|
||||
drop1Slash ('/':x) = x
|
||||
drop1Slash x = x
|
||||
|
||||
piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String)
|
||||
piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))
|
||||
piecesFromString "" = ([], Nothing)
|
||||
piecesFromString x =
|
||||
case (this, rest) of
|
||||
@ -182,11 +195,19 @@ ttToType (TTTerm s) = ConT $ mkName s
|
||||
ttToType (TTApp x y) = ttToType x `AppT` ttToType y
|
||||
ttToType (TTList t) = ListT `AppT` ttToType t
|
||||
|
||||
pieceFromString :: String -> Either String (CheckOverlap, Piece String)
|
||||
pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
|
||||
pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
|
||||
pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
|
||||
pieceFromString ('#':x) = Right $ (True, Dynamic x)
|
||||
pieceFromString ('*':x) = Left x
|
||||
pieceFromString ('+':x) = Left x
|
||||
|
||||
pieceFromString ('*':'!':x) = Left (False, x)
|
||||
pieceFromString ('+':'!':x) = Left (False, x)
|
||||
|
||||
pieceFromString ('!':'*':x) = Left (False, x)
|
||||
pieceFromString ('!':'+':x) = Left (False, x)
|
||||
|
||||
pieceFromString ('*':x) = Left (True, x)
|
||||
pieceFromString ('+':x) = Left (True, x)
|
||||
|
||||
pieceFromString ('!':x) = Right $ (False, Static x)
|
||||
pieceFromString x = Right $ (True, Static x)
|
||||
|
||||
@ -157,8 +157,8 @@ methodMapName s = mkName $ "methods" ++ s
|
||||
buildMethodMap :: MkDispatchSettings
|
||||
-> FlatResource a
|
||||
-> Q (Maybe Dec)
|
||||
buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
|
||||
buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do
|
||||
buildMethodMap _ (FlatResource _ _ _ (Methods _ []) _) = return Nothing -- single handle function
|
||||
buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods) _check) = do
|
||||
fromList <- [|Map.fromList|]
|
||||
methods' <- mapM go methods
|
||||
let exp = fromList `AppE` ListE methods'
|
||||
@ -171,7 +171,7 @@ buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods))
|
||||
pack' <- [|encodeUtf8 . pack|]
|
||||
let isDynamic Dynamic{} = True
|
||||
isDynamic _ = False
|
||||
let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti
|
||||
let argCount = length (filter isDynamic pieces) + maybe 0 (const 1) mmulti
|
||||
xs <- replicateM argCount $ newName "arg"
|
||||
runHandler <- mdsRunHandler mds
|
||||
let rhs
|
||||
@ -183,13 +183,13 @@ buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods))
|
||||
[ pack' `AppE` LitE (StringL method)
|
||||
, rhs
|
||||
]
|
||||
buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
|
||||
buildMethodMap _ (FlatResource _ _ _ Subsite{} _check) = return Nothing
|
||||
|
||||
-- | Build a single 'D.Route' expression.
|
||||
buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp
|
||||
buildRoute mds (FlatResource parents name resPieces resDisp) = do
|
||||
buildRoute mds (FlatResource parents name resPieces resDisp _) = do
|
||||
-- First two arguments to D.Route
|
||||
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
|
||||
routePieces <- ListE <$> mapM convertPiece allPieces
|
||||
isMulti <-
|
||||
case resDisp of
|
||||
Methods Nothing _ -> [|False|]
|
||||
@ -202,14 +202,14 @@ buildRoute mds (FlatResource parents name resPieces resDisp) = do
|
||||
mds
|
||||
parents
|
||||
name
|
||||
(map snd allPieces)
|
||||
allPieces
|
||||
resDisp)
|
||||
|]
|
||||
where
|
||||
allPieces = concat $ map snd parents ++ [resPieces]
|
||||
|
||||
routeArg3 :: MkDispatchSettings
|
||||
-> [(String, [(CheckOverlap, Piece a)])]
|
||||
-> [(String, [Piece a])]
|
||||
-> String -- ^ name of resource
|
||||
-> [Piece a]
|
||||
-> Dispatch a
|
||||
@ -277,7 +277,7 @@ routeArg3 mds parents name resPieces resDisp = do
|
||||
-- | The final expression in the individual Route definitions.
|
||||
buildCaller :: MkDispatchSettings
|
||||
-> Name -- ^ xrest
|
||||
-> [(String, [(CheckOverlap, Piece a)])]
|
||||
-> [(String, [Piece a])]
|
||||
-> String -- ^ name of resource
|
||||
-> Dispatch a
|
||||
-> [Name] -- ^ ys
|
||||
@ -356,7 +356,7 @@ convertPiece :: Piece a -> Q Exp
|
||||
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
|
||||
convertPiece (Dynamic _) = [|D.Dynamic|]
|
||||
|
||||
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
|
||||
routeFromDynamics :: [(String, [Piece a])] -- ^ parents
|
||||
-> String -- ^ constructor name
|
||||
-> [Name]
|
||||
-> Exp
|
||||
@ -364,7 +364,7 @@ routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName n
|
||||
routeFromDynamics ((parent, pieces):rest) name ys =
|
||||
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
|
||||
where
|
||||
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
|
||||
(here', ys') = splitAt (length $ filter isDynamic pieces) ys
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic _ = False
|
||||
here = map VarE here' ++ [routeFromDynamics rest name ys']
|
||||
|
||||
@ -43,7 +43,7 @@ mkParseRouteClauses ress' = do
|
||||
[dispatchFun]
|
||||
where
|
||||
ress = map noMethods $ flatten ress'
|
||||
noMethods (FlatResource a b c d) = FlatResource a b c $ noMethods' d
|
||||
noMethods (FlatResource a b c d e) = FlatResource a b c (noMethods' d) e
|
||||
noMethods' (Methods a _) = Methods a []
|
||||
noMethods' (Subsite a b) = Subsite a b
|
||||
|
||||
@ -56,9 +56,9 @@ mkParseRouteInstance typ ress = do
|
||||
|
||||
-- | Build a single 'D.Route' expression.
|
||||
buildRoute :: Name -> FlatResource a -> Q Exp
|
||||
buildRoute query (FlatResource parents name resPieces resDisp) = do
|
||||
buildRoute query (FlatResource parents name resPieces resDisp _check) = do
|
||||
-- First two arguments to D.Route
|
||||
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
|
||||
routePieces <- ListE <$> mapM convertPiece allPieces
|
||||
isMulti <-
|
||||
case resDisp of
|
||||
Methods Nothing _ -> [|False|]
|
||||
@ -71,14 +71,14 @@ buildRoute query (FlatResource parents name resPieces resDisp) = do
|
||||
query
|
||||
parents
|
||||
name
|
||||
(map snd allPieces)
|
||||
allPieces
|
||||
resDisp)
|
||||
|]
|
||||
where
|
||||
allPieces = concat $ map snd parents ++ [resPieces]
|
||||
|
||||
routeArg3 :: Name -- ^ query string parameters
|
||||
-> [(String, [(CheckOverlap, Piece a)])]
|
||||
-> [(String, [Piece a])]
|
||||
-> String -- ^ name of resource
|
||||
-> [Piece a]
|
||||
-> Dispatch a
|
||||
@ -146,7 +146,7 @@ routeArg3 query parents name resPieces resDisp = do
|
||||
-- | The final expression in the individual Route definitions.
|
||||
buildCaller :: Name -- ^ query string parameters
|
||||
-> Name -- ^ xrest
|
||||
-> [(String, [(CheckOverlap, Piece a)])]
|
||||
-> [(String, [Piece a])]
|
||||
-> String -- ^ name of resource
|
||||
-> Dispatch a
|
||||
-> [Name] -- ^ ys
|
||||
@ -164,7 +164,7 @@ convertPiece :: Piece a -> Q Exp
|
||||
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
|
||||
convertPiece (Dynamic _) = [|D.Dynamic|]
|
||||
|
||||
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
|
||||
routeFromDynamics :: [(String, [Piece a])] -- ^ parents
|
||||
-> String -- ^ constructor name
|
||||
-> [Name]
|
||||
-> Exp
|
||||
@ -172,7 +172,7 @@ routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName n
|
||||
routeFromDynamics ((parent, pieces):rest) name ys =
|
||||
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
|
||||
where
|
||||
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
|
||||
(here', ys') = splitAt (length $ filter isDynamic pieces) ys
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic _ = False
|
||||
here = map VarE here' ++ [routeFromDynamics rest name ys']
|
||||
|
||||
@ -27,7 +27,7 @@ mkRouteCons =
|
||||
con = NormalC (mkName $ resourceName res)
|
||||
$ map (\x -> (NotStrict, x))
|
||||
$ concat [singles, multi, sub]
|
||||
singles = concatMap (toSingle . snd) $ resourcePieces res
|
||||
singles = concatMap toSingle $ resourcePieces res
|
||||
toSingle Static{} = []
|
||||
toSingle (Dynamic typ) = [typ]
|
||||
|
||||
@ -37,7 +37,7 @@ mkRouteCons =
|
||||
case resourceDispatch res of
|
||||
Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
|
||||
_ -> []
|
||||
mkRouteCon (ResourceParent name pieces children) =
|
||||
mkRouteCon (ResourceParent name _check pieces children) =
|
||||
([con], dec : decs)
|
||||
where
|
||||
(cons, decs) = mkRouteCons children
|
||||
@ -46,7 +46,7 @@ mkRouteCons =
|
||||
$ concat [singles, [ConT $ mkName name]]
|
||||
dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
|
||||
|
||||
singles = concatMap (toSingle . snd) pieces
|
||||
singles = concatMap toSingle pieces
|
||||
toSingle Static{} = []
|
||||
toSingle (Dynamic typ) = [typ]
|
||||
|
||||
@ -58,15 +58,15 @@ mkRenderRouteClauses =
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic _ = False
|
||||
|
||||
go (ResourceParent name pieces children) = do
|
||||
let cnt = length $ filter (isDynamic . snd) pieces
|
||||
go (ResourceParent name _check pieces children) = do
|
||||
let cnt = length $ filter isDynamic pieces
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
child <- newName "child"
|
||||
let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns
|
||||
|
||||
childRender <- newName "childRender"
|
||||
let rr = VarE childRender
|
||||
@ -84,7 +84,7 @@ mkRenderRouteClauses =
|
||||
return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
|
||||
|
||||
go (ResourceLeaf res) = do
|
||||
let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
|
||||
let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
sub <-
|
||||
case resourceDispatch res of
|
||||
@ -94,7 +94,7 @@ mkRenderRouteClauses =
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd $ resourcePieces res) dyns
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
|
||||
|
||||
piecesMulti <-
|
||||
case resourceMulti res of
|
||||
|
||||
@ -19,11 +19,11 @@ mkRouteAttrsInstance typ ress = do
|
||||
|
||||
goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
|
||||
goTree front (ResourceLeaf res) = fmap return $ goRes front res
|
||||
goTree front (ResourceParent name pieces trees) =
|
||||
goTree front (ResourceParent name _check pieces trees) =
|
||||
fmap concat $ mapM (goTree front') trees
|
||||
where
|
||||
ignored = ((replicate toIgnore WildP ++) . return)
|
||||
toIgnore = length $ filter (isDynamic . snd) pieces
|
||||
toIgnore = length $ filter isDynamic pieces
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic Static{} = False
|
||||
front' = front . ConP (mkName name) . ignored
|
||||
|
||||
@ -52,14 +52,14 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
|
||||
(NormalB $ helperE `AppE` pathInfo)
|
||||
[FunD helperName $ clauses ++ [clause404']]
|
||||
where
|
||||
handlePiece :: (CheckOverlap, Piece a) -> Q (Pat, Maybe Exp)
|
||||
handlePiece (_, Static str) = return (LitP $ StringL str, Nothing)
|
||||
handlePiece (_, Dynamic _) = do
|
||||
handlePiece :: Piece a -> Q (Pat, Maybe Exp)
|
||||
handlePiece (Static str) = return (LitP $ StringL str, Nothing)
|
||||
handlePiece (Dynamic _) = do
|
||||
x <- newName "dyn"
|
||||
let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
|
||||
return (pat, Just $ VarE x)
|
||||
|
||||
handlePieces :: [(CheckOverlap, Piece a)] -> Q ([Pat], [Exp])
|
||||
handlePieces :: [Piece a] -> Q ([Pat], [Exp])
|
||||
handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece
|
||||
|
||||
mkCon :: String -> [Exp] -> Exp
|
||||
@ -72,7 +72,7 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
|
||||
addPat x y = ConP '(:) [x, y]
|
||||
|
||||
go :: SDC -> ResourceTree a -> Q Clause
|
||||
go sdc (ResourceParent name pieces children) = do
|
||||
go sdc (ResourceParent name _check pieces children) = do
|
||||
(pats, dyns) <- handlePieces pieces
|
||||
let sdc' = sdc
|
||||
{ extraParams = extraParams sdc ++ dyns
|
||||
@ -91,7 +91,7 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
|
||||
[mkPathPat restP pats]
|
||||
(NormalB $ helperE `AppE` restE)
|
||||
[FunD helperName $ childClauses ++ [clause404 sdc]]
|
||||
go SDC {..} (ResourceLeaf (Resource name pieces dispatch _)) = do
|
||||
go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do
|
||||
(pats, dyns) <- handlePieces pieces
|
||||
|
||||
(chooseMethod, finalPat) <- handleDispatch dispatch dyns
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Routes.TH.Types
|
||||
( -- * Data types
|
||||
@ -15,41 +16,37 @@ module Yesod.Routes.TH.Types
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Control.Arrow (second)
|
||||
|
||||
data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ]
|
||||
data ResourceTree typ
|
||||
= ResourceLeaf (Resource typ)
|
||||
| ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]
|
||||
deriving Functor
|
||||
|
||||
resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)]
|
||||
resourceTreePieces :: ResourceTree typ -> [Piece typ]
|
||||
resourceTreePieces (ResourceLeaf r) = resourcePieces r
|
||||
resourceTreePieces (ResourceParent _ x _) = x
|
||||
resourceTreePieces (ResourceParent _ _ x _) = x
|
||||
|
||||
resourceTreeName :: ResourceTree typ -> String
|
||||
resourceTreeName (ResourceLeaf r) = resourceName r
|
||||
resourceTreeName (ResourceParent x _ _) = x
|
||||
|
||||
instance Functor ResourceTree where
|
||||
fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r)
|
||||
fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c
|
||||
resourceTreeName (ResourceParent x _ _ _) = x
|
||||
|
||||
instance Lift t => Lift (ResourceTree t) where
|
||||
lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
|
||||
lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|]
|
||||
lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]
|
||||
|
||||
data Resource typ = Resource
|
||||
{ resourceName :: String
|
||||
, resourcePieces :: [(CheckOverlap, Piece typ)]
|
||||
, resourcePieces :: [Piece typ]
|
||||
, resourceDispatch :: Dispatch typ
|
||||
, resourceAttrs :: [String]
|
||||
, resourceCheck :: CheckOverlap
|
||||
}
|
||||
deriving Show
|
||||
deriving (Show, Functor)
|
||||
|
||||
type CheckOverlap = Bool
|
||||
|
||||
instance Functor Resource where
|
||||
fmap f (Resource a b c d) = Resource a (map (second $ fmap f) b) (fmap f c) d
|
||||
|
||||
instance Lift t => Lift (Resource t) where
|
||||
lift (Resource a b c d) = [|Resource a b c d|]
|
||||
lift (Resource a b c d e) = [|Resource a b c d e|]
|
||||
|
||||
data Piece typ = Static String | Dynamic typ
|
||||
deriving Show
|
||||
@ -86,12 +83,18 @@ resourceMulti :: Resource typ -> Maybe typ
|
||||
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
|
||||
resourceMulti _ = Nothing
|
||||
|
||||
data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
|
||||
data FlatResource a = FlatResource
|
||||
{ frParentPieces :: [(String, [Piece a])]
|
||||
, frName :: String
|
||||
, frPieces :: [Piece a]
|
||||
, frDispatch :: Dispatch a
|
||||
, frCheck :: Bool
|
||||
}
|
||||
|
||||
flatten :: [ResourceTree a] -> [FlatResource a]
|
||||
flatten =
|
||||
concatMap (go id)
|
||||
concatMap (go id True)
|
||||
where
|
||||
go front (ResourceLeaf (Resource a b c _)) = [FlatResource (front []) a b c]
|
||||
go front (ResourceParent name pieces children) =
|
||||
concatMap (go (front . ((name, pieces):))) children
|
||||
go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)]
|
||||
go front check' (ResourceParent name check pieces children) =
|
||||
concatMap (go (front . ((name, pieces):)) (check && check')) children
|
||||
|
||||
@ -112,21 +112,21 @@ getMySubParam _ = MySubParam
|
||||
do
|
||||
texts <- [t|[Text]|]
|
||||
let resLeaves = map ResourceLeaf
|
||||
[ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"]
|
||||
, Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) (Methods Nothing ["GET", "POST"]) []
|
||||
, Resource "WikiR" (addCheck [Static "wiki"]) (Methods (Just texts) []) []
|
||||
, Resource "SubsiteR" (addCheck [Static "subsite"]) (Subsite (ConT ''MySub) "getMySub") []
|
||||
, Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) (Subsite (ConT ''MySubParam) "getMySubParam") []
|
||||
[ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True
|
||||
, Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] (Methods Nothing ["GET", "POST"]) [] True
|
||||
, Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True
|
||||
, Resource "SubsiteR" [Static "subsite"] (Subsite (ConT ''MySub) "getMySub") [] True
|
||||
, Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] (Subsite (ConT ''MySubParam) "getMySubParam") [] True
|
||||
]
|
||||
resParent = ResourceParent
|
||||
"ParentR"
|
||||
[ (True, Static "foo")
|
||||
, (True, Dynamic $ ConT ''Text)
|
||||
True
|
||||
[ Static "foo"
|
||||
, Dynamic $ ConT ''Text
|
||||
]
|
||||
[ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"]
|
||||
[ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True
|
||||
]
|
||||
ress = resParent : resLeaves
|
||||
addCheck = map ((,) True)
|
||||
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
|
||||
rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
|
||||
prinst <- mkParseRouteInstance (ConT ''MyApp) ress
|
||||
@ -347,6 +347,29 @@ main = hspec $ do
|
||||
/foo Foo1
|
||||
/#!String Foo2
|
||||
/!foo Foo3
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "obeys multipiece ignore rules #779" $ do
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/+![String] Foo2
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "ignore rules for entire route #779" $ do
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
!/+[String] Foo2
|
||||
!/#String Foo3
|
||||
!/foo Foo4
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "ignore rules for hierarchy" $ do
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/+[String] Foo1
|
||||
!/foo Foo2:
|
||||
/foo Foo3
|
||||
/foo Foo4:
|
||||
/!#foo Foo5
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "proper boolean logic" $ do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user