From 255d71171c28d411d564b0d1e775959e4d55ccc9 Mon Sep 17 00:00:00 2001 From: Michael Date: Wed, 13 Jun 2012 09:26:21 +0300 Subject: [PATCH] Beginning of hierarchichal routes, not done --- yesod-routes/Yesod/Routes/Overlap.hs | 47 +++++++++++----- yesod-routes/Yesod/Routes/Parse.hs | 32 +++++++---- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 28 +++++++--- yesod-routes/Yesod/Routes/TH/RenderRoute.hs | 62 +++++++++++++++++---- yesod-routes/Yesod/Routes/TH/Types.hs | 21 +++++++ yesod-routes/test/Hierarchy.hs | 23 ++++++++ yesod-routes/test/main.hs | 9 +-- yesod-routes/yesod-routes.cabal | 1 + 8 files changed, 175 insertions(+), 48 deletions(-) create mode 100644 yesod-routes/test/Hierarchy.hs diff --git a/yesod-routes/Yesod/Routes/Overlap.hs b/yesod-routes/Yesod/Routes/Overlap.hs index aa116b04..35406d4a 100644 --- a/yesod-routes/Yesod/Routes/Overlap.hs +++ b/yesod-routes/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 :: Piece t -> Piece t -> Bool 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/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs index b17e5fec..fc16eef3 100644 --- a/yesod-routes/Yesod/Routes/Parse.hs +++ b/yesod-routes/Yesod/Routes/Parse.hs @@ -10,7 +10,6 @@ module Yesod.Routes.Parse ) 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 @@ parseRoutesNoCheck = QuasiQuoter -- | 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/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index ab2424a7..e0bfdaaf 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -17,6 +17,16 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Control.Applicative ((<$>)) import Data.List (foldl') +data FlatResource a = FlatResource ([String] -> [String]) String [(CheckOverlap, Piece a)] (Dispatch a) + +flatten :: [ResourceTree a] -> [FlatResource a] +flatten = + concatMap (go id id) + where + go front1 front2 (ResourceLeaf (Resource a b c)) = [FlatResource front1 a (front2 b) c] + go front1 front2 (ResourceParent name pieces children) = + concatMap (go (front1 . (name:)) (front2 . (pieces++))) children + -- | -- -- This function will generate a single clause that will address all @@ -83,9 +93,9 @@ import Data.List (foldl') 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,16 +140,18 @@ mkDispatchClause runHandler dispatcher fixHandler ress = do 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 names name pieces (Methods mmulti methods)) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods' @@ -156,11 +168,11 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do 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 names name resPieces resDisp) = do -- First two arguments to D.Route routePieces <- ListE <$> mapM (convertPiece . snd) resPieces isMulti <- diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs index bc331ed4..3ba87b77 100644 --- a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs @@ -14,17 +14,19 @@ import Control.Monad (replicateM) 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 @@ mkRouteCons = 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 @@ mkRenderRouteClauses = -- 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/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs index e0a74b5c..52cd446f 100644 --- a/yesod-routes/Yesod/Routes/TH/Types.hs +++ b/yesod-routes/Yesod/Routes/TH/Types.hs @@ -2,16 +2,37 @@ 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 , resourcePieces :: [(CheckOverlap, Piece typ)] diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs new file mode 100644 index 00000000..e7bd3451 --- /dev/null +++ b/yesod-routes/test/Hierarchy.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Hierarchy (hierarchy) where + +import Test.Hspec.Monadic +import Test.Hspec.HUnit () +import Yesod.Routes.Parse +import Yesod.Routes.TH +import Yesod.Routes.Class +import Language.Haskell.TH.Syntax + +data Hierarchy = Hierarchy + +mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) [parseRoutes| +/ HomeR GET +/admin/#Int AdminR: + / AdminRootR GET + /login LoginR GET POST +|] + +hierarchy :: Specs +hierarchy = return () diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index af73aa09..690e6795 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -20,6 +20,7 @@ import Yesod.Routes.Parse (parseRoutesNoCheck) import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax +import Hierarchy class ToText a where toText :: a -> Text @@ -126,7 +127,7 @@ class RunHandler sub master where 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 +138,13 @@ do 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 +328,7 @@ main = hspecX $ do /bar/baz Foo3 |] findOverlapNames routes @?= [] + hierarchy getRootR :: Text getRootR = pack "this is the root" diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 28d69eca..a523711c 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -36,6 +36,7 @@ test-suite runtests type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test + other-modules: Hierarchy build-depends: base >= 4.3 && < 5 , yesod-routes