From 0e0880dfe4749a7bc61354549bbaf5da6f1bed2f Mon Sep 17 00:00:00 2001 From: Michael Date: Wed, 13 Jun 2012 10:00:20 +0300 Subject: [PATCH] Hierarchy dispatching --- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 44 ++++++++---- yesod-routes/test/Hierarchy.hs | 86 +++++++++++++++++++++++- yesod-routes/test/main.hs | 29 -------- 3 files changed, 114 insertions(+), 45 deletions(-) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index e0bfdaaf..338d1463 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -17,15 +17,15 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Control.Applicative ((<$>)) import Data.List (foldl') -data FlatResource a = FlatResource ([String] -> [String]) String [(CheckOverlap, Piece a)] (Dispatch a) +data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a) flatten :: [ResourceTree a] -> [FlatResource a] flatten = - concatMap (go id id) + concatMap (go 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 + go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c] + go front (ResourceParent name pieces children) = + concatMap (go (front . ((name, pieces):))) children -- | -- @@ -151,13 +151,14 @@ buildMethodMap :: Q Exp -- ^ fixHandler -> FlatResource a -> Q (Maybe Dec) buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function -buildMethodMap fixHandler (FlatResource names name pieces (Methods mmulti methods)) = do +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 @@ -172,24 +173,27 @@ buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing -- | Build a single 'D.Route' expression. buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp -buildRoute runHandler dispatcher fixHandler (FlatResource names name resPieces resDisp) = do +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 @@ -228,7 +232,7 @@ routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do _ -> 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|] @@ -251,11 +255,12 @@ buildCaller :: Q Exp -- ^ runHandler -> 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" @@ -266,7 +271,7 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do 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 @@ -321,3 +326,16 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do 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/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index e7bd3451..c272bb94 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/yesod-routes/test/Hierarchy.hs @@ -1,23 +1,103 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Hierarchy (hierarchy) where +{-# 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 -mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) [parseRoutes| +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 = return () +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/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 690e6795..1eff36a4 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -22,12 +22,6 @@ import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax import Hierarchy -class ToText a where - toText :: a -> Text - -instance ToText Text where toText = id -instance ToText String where toText = pack - result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts @@ -102,29 +96,6 @@ instance RenderRoute MySubParam where 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 = map ResourceLeaf