diff --git a/Yesod/Routes/Overlap.hs b/Yesod/Routes/Overlap.hs --- a/Yesod/Routes/Overlap.hs +++ b/Yesod/Routes/Overlap.hs @@ -2,27 +2,41 @@ module Yesod.Routes.Overlap ( findOverlaps , findOverlapNames + , Overlap (..) ) where import Yesod.Routes.TH.Types -import Control.Arrow ((***)) -import Data.Maybe (mapMaybe) +import Data.List (intercalate) -findOverlaps :: [Resource t] -> [(Resource t, Resource t)] -findOverlaps [] = [] -findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs +data Overlap t = Overlap + { overlapParents :: [String] -> [String] -- ^ parent resource trees + , overlap1 :: ResourceTree t + , overlap2 :: ResourceTree t + } -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 +findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t] +findOverlaps _ [] = [] +findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs -hasSuffix :: Resource t -> Bool -hasSuffix r = +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 @@ -50,9 +64,14 @@ piecesOverlap (Static x) (Static y) = x == y piecesOverlap _ _ = True -findOverlapNames :: [Resource t] -> [(String, String)] -findOverlapNames = map (resourceName *** resourceName) . findOverlaps - +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 {- -- n^2, should be a way to speed it up findOverlaps :: [Resource a] -> [[Resource a]] diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs --- a/Yesod/Routes/Parse.hs +++ b/Yesod/Routes/Parse.hs @@ -10,7 +10,6 @@ ) where import Language.Haskell.TH.Syntax -import Data.Maybe import Data.Char (isUpper) import Language.Haskell.TH.Quote import qualified System.IO as SIO @@ -55,18 +54,29 @@ -- | Convert a multi-line string to a set of resources. See documentation for -- the format of this string. This is a partial function which calls 'error' on -- invalid input. -resourcesFromString :: String -> [Resource String] +resourcesFromString :: String -> [ResourceTree String] resourcesFromString = - mapMaybe go . lines + fst . parse 0 . lines where - go s = - case takeWhile (/= "--") $ words s of - (pattern:constr:rest) -> - let (pieces, mmulti) = piecesFromString $ drop1Slash pattern - disp = dispatchFromString rest mmulti - in Just $ Resource constr pieces disp - [] -> Nothing - _ -> error $ "Invalid resource line: " ++ s + parse _ [] = ([], []) + parse indent (thisLine:otherLines) + | length spaces < indent = ([], thisLine : otherLines) + | otherwise = (this others, remainder) + where + spaces = takeWhile (== ' ') thisLine + (others, remainder) = parse indent otherLines' + (this, otherLines') = + 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'') + (pattern:constr:rest) -> + let (pieces, mmulti) = piecesFromString $ drop1Slash pattern + disp = dispatchFromString rest mmulti + in ((ResourceLeaf (Resource constr pieces disp):), otherLines) + [] -> (id, otherLines) + _ -> error $ "Invalid resource line: " ++ thisLine dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti diff --git a/Yesod/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs --- a/Yesod/Routes/TH/Dispatch.hs +++ b/Yesod/Routes/TH/Dispatch.hs @@ -17,6 +17,16 @@ import Control.Applicative ((<$>)) import Data.List (foldl') +data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a) + +flatten :: [ResourceTree a] -> [FlatResource a] +flatten = + concatMap (go id) + 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 + -- | -- -- This function will generate a single clause that will address all @@ -83,9 +93,9 @@ mkDispatchClause :: Q Exp -- ^ runHandler function -> Q Exp -- ^ dispatcher function -> Q Exp -- ^ fixHandler function - -> [Resource a] + -> [ResourceTree a] -> Q Clause -mkDispatchClause runHandler dispatcher fixHandler ress = do +mkDispatchClause runHandler dispatcher fixHandler ress' = do -- Allocate the names to be used. Start off with the names passed to the -- function itself (with a 0 suffix). -- @@ -130,22 +140,25 @@ Nothing -> $(return $ VarE app4040) |] return $ Clause pats (NormalB u) $ dispatchFun : methodMaps + where + ress = flatten ress' -- | Determine the name of the method map for a given resource name. methodMapName :: String -> Name methodMapName s = mkName $ "methods" ++ s buildMethodMap :: Q Exp -- ^ fixHandler - -> Resource a + -> FlatResource a -> Q (Maybe Dec) -buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function -buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do +buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function +buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods' let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []] return $ Just fun where + pieces = concat $ map snd parents ++ [pieces'] go method = do fh <- fixHandler let func = VarE $ mkName $ map toLower method ++ name @@ -156,28 +169,31 @@ xs <- replicateM argCount $ newName "arg" let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs) return $ TupE [pack' `AppE` LitE (StringL method), rhs] -buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing +buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing -- | Build a single 'D.Route' expression. -buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp -buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do +buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp +buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do -- First two arguments to D.Route - routePieces <- ListE <$> mapM (convertPiece . snd) resPieces + routePieces <- ListE <$> mapM (convertPiece . snd) allPieces isMulti <- case resDisp of Methods Nothing _ -> [|False|] _ -> [|True|] - [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|] + [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|] + where + allPieces = concat $ map snd parents ++ [resPieces] routeArg3 :: Q Exp -- ^ runHandler -> Q Exp -- ^ dispatcher -> Q Exp -- ^ fixHandler + -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> [Piece a] -> Dispatch a -> Q Exp -routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do +routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do pieces <- newName "pieces" -- Allocate input piece variables (xs) and variables that have been @@ -216,7 +232,7 @@ _ -> return ([], []) -- The final expression that actually uses the values we've computed - caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest' + caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest' -- Put together all the statements just <- [|Just|] @@ -239,11 +255,12 @@ -> Q Exp -- ^ dispatcher -> Q Exp -- ^ fixHandler -> Name -- ^ xrest + -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> Dispatch a -> [Name] -- ^ ys -> Q Exp -buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do +buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do master <- newName "master" sub <- newName "sub" toMaster <- newName "toMaster" @@ -254,7 +271,7 @@ let pat = map VarP [master, sub, toMaster, app404, handler405, method] -- Create the route - let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys + let route = routeFromDynamics parents name ys exp <- case resDisp of @@ -309,3 +326,16 @@ convertPiece :: Piece a -> Q Exp convertPiece (Static s) = [|D.Static (pack $(lift s))|] convertPiece (Dynamic _) = [|D.Dynamic|] + +routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents + -> String -- ^ constructor name + -> [Name] + -> Exp +routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys +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 + isDynamic Dynamic{} = True + isDynamic _ = False + here = map VarE here' ++ [routeFromDynamics rest name ys'] diff --git a/Yesod/Routes/TH/RenderRoute.hs b/Yesod/Routes/TH/RenderRoute.hs --- a/Yesod/Routes/TH/RenderRoute.hs +++ b/Yesod/Routes/TH/RenderRoute.hs @@ -14,17 +14,19 @@ import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class +import Data.Monoid (mconcat) -- | Generate the constructors of a route data type. -mkRouteCons :: [Resource Type] -> [Con] +mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec]) mkRouteCons = - map mkRouteCon + mconcat . map mkRouteCon where - mkRouteCon res = - NormalC (mkName $ resourceName res) + mkRouteCon (ResourceLeaf res) = + ([con], []) + where + con = NormalC (mkName $ resourceName res) $ map (\x -> (NotStrict, x)) $ concat [singles, multi, sub] - where singles = concatMap (toSingle . snd) $ resourcePieces res toSingle Static{} = [] toSingle (Dynamic typ) = [typ] @@ -35,16 +37,53 @@ case resourceDispatch res of Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] _ -> [] + mkRouteCon (ResourceParent name pieces children) = + ([con], dec : decs) + where + (cons, decs) = mkRouteCons children + con = NormalC (mkName name) + $ map (\x -> (NotStrict, x)) + $ concat [singles, [ConT $ mkName name]] + dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] + singles = concatMap (toSingle . snd) pieces + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] + -- | Clauses for the 'renderRoute' method. -mkRenderRouteClauses :: [Resource Type] -> Q [Clause] +mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] mkRenderRouteClauses = mapM go where isDynamic Dynamic{} = True isDynamic _ = False - go res = do + go (ResourceParent name pieces children) = do + let cnt = length $ filter (isDynamic . snd) 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 + + childRender <- newName "childRender" + let rr = VarE childRender + childClauses <- mkRenderRouteClauses children + + a <- newName "a" + b <- newName "b" + + colon <- [|(:)|] + let cons y ys = InfixE (Just y) colon (Just ys) + let pieces' = foldr cons (VarE a) piecesSingle + + let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child) + + 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) dyns <- replicateM cnt $ newName "dyn" sub <- @@ -93,18 +132,19 @@ -- This includes both the 'Route' associated type and the -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'. -mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec +mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance = mkRenderRouteInstance' [] -- | A more general version of 'mkRenderRouteInstance' which takes an -- additional context. -mkRenderRouteInstance' :: Cxt -> Type -> [Resource Type] -> Q Dec +mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance' cxt typ ress = do cls <- mkRenderRouteClauses ress + let (cons, decs) = mkRouteCons ress return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ) - [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes + [ DataInstD [] ''Route [typ] cons clazzes , FunD (mkName "renderRoute") cls - ] + ] : decs where clazzes = [''Show, ''Eq, ''Read] diff --git a/Yesod/Routes/TH/Types.hs b/Yesod/Routes/TH/Types.hs --- a/Yesod/Routes/TH/Types.hs +++ b/Yesod/Routes/TH/Types.hs @@ -2,15 +2,36 @@ module Yesod.Routes.TH.Types ( -- * Data types Resource (..) + , ResourceTree (..) , Piece (..) , Dispatch (..) , CheckOverlap -- ** Helper functions , resourceMulti + , resourceTreePieces + , resourceTreeName ) where import Language.Haskell.TH.Syntax import Control.Arrow (second) + +data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ] + +resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)] +resourceTreePieces (ResourceLeaf r) = resourcePieces r +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 + +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)|] data Resource typ = Resource { resourceName :: String diff --git a/test/Hierarchy.hs b/test/Hierarchy.hs new file mode 100644 --- /dev/null +++ b/test/Hierarchy.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Hierarchy + ( hierarchy + , Dispatcher (..) + , RunHandler (..) + , Handler + , App + , toText + ) where + +import Test.Hspec.Monadic +import Test.Hspec.HUnit () +import Test.HUnit +import Yesod.Routes.Parse +import Yesod.Routes.TH +import Yesod.Routes.Class +import Language.Haskell.TH.Syntax +import qualified Yesod.Routes.Class as YRC +import Data.Text (Text, pack, append) + +class ToText a where + toText :: a -> Text + +instance ToText Text where toText = id +instance ToText String where toText = pack + +type Handler sub master = Text +type App sub master = (Text, Maybe (YRC.Route master)) + +class Dispatcher sub master where + dispatcher + :: master + -> sub + -> (YRC.Route sub -> YRC.Route master) + -> App sub master -- ^ 404 page + -> (YRC.Route sub -> App sub master) -- ^ 405 page + -> Text -- ^ method + -> [Text] + -> App sub master + +class RunHandler sub master where + runHandler + :: Handler sub master + -> master + -> sub + -> Maybe (YRC.Route sub) + -> (YRC.Route sub -> YRC.Route master) + -> App sub master + +data Hierarchy = Hierarchy + +do + let resources = [parseRoutes| +/ HomeR GET +/admin/#Int AdminR: + / AdminRootR GET + /login LoginR GET POST + /table/#Text TableR GET +|] + rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources + dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources + return + $ InstanceD + [] + (ConT ''Dispatcher + `AppT` ConT ''Hierarchy + `AppT` ConT ''Hierarchy) + [FunD (mkName "dispatcher") [dispatch]] + : rrinst + +getHomeR :: Handler sub master +getHomeR = "home" + +getAdminRootR :: Int -> Handler sub master +getAdminRootR i = pack $ "admin root: " ++ show i + +getLoginR :: Int -> Handler sub master +getLoginR i = pack $ "login: " ++ show i + +postLoginR :: Int -> Handler sub master +postLoginR i = pack $ "post login: " ++ show i + +getTableR :: Int -> Text -> Handler sub master +getTableR _ t = append "TableR " t + +instance RunHandler Hierarchy master where + runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute) + +hierarchy :: Specs +hierarchy = describe "hierarchy" $ do + it "renders root correctly" $ + renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], []) + it "renders table correctly" $ + renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], []) + let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps) + it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR) + it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar") diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -20,12 +20,7 @@ import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax - -class ToText a where - toText :: a -> Text - -instance ToText Text where toText = id -instance ToText String where toText = pack +import Hierarchy result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts @@ -101,32 +96,9 @@ getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam -type Handler sub master = Text -type App sub master = (Text, Maybe (YRC.Route master)) - -class Dispatcher sub master where - dispatcher - :: master - -> sub - -> (YRC.Route sub -> YRC.Route master) - -> App sub master -- ^ 404 page - -> (YRC.Route sub -> App sub master) -- ^ 405 page - -> Text -- ^ method - -> [Text] - -> App sub master - -class RunHandler sub master where - runHandler - :: Handler sub master - -> master - -> sub - -> Maybe (YRC.Route sub) - -> (YRC.Route sub -> YRC.Route master) - -> App sub master - do texts <- [t|[Text]|] - let ress = + let ress = map ResourceLeaf [ Resource "RootR" [] $ Methods Nothing ["GET"] , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"] , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) [] @@ -137,14 +109,13 @@ rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress return - [ rrinst - , InstanceD + $ InstanceD [] (ConT ''Dispatcher `AppT` ConT ''MyApp `AppT` ConT ''MyApp) [FunD (mkName "dispatcher") [dispatch]] - ] + : rrinst instance RunHandler MyApp master where runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute) @@ -328,6 +299,7 @@ /bar/baz Foo3 |] findOverlapNames routes @?= [] + hierarchy getRootR :: Text getRootR = pack "this is the root" diff --git a/yesod-routes.cabal b/yesod-routes.cabal --- a/yesod-routes.cabal +++ b/yesod-routes.cabal @@ -1,5 +1,5 @@ name: yesod-routes -version: 1.0.1.2 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -36,12 +36,13 @@ type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test + other-modules: Hierarchy build-depends: base >= 4.3 && < 5 , yesod-routes , text >= 0.5 && < 0.12 , HUnit >= 1.2 && < 1.3 - , hspec >= 0.6 && < 1.2 + , hspec >= 1.3 && < 1.4 , containers , template-haskell , path-pieces