From 9fad1071fce5ef52f1b3ea7f9e4f6d344c9109f4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 24 Feb 2014 14:20:17 +0200 Subject: [PATCH] Incomplete changes --- yesod-routes/Yesod/Routes/TH/Simple.hs | 57 ++++++++++++++++++++++++++ yesod-routes/test/Hierarchy.hs | 12 +++++- yesod-routes/test/main.hs | 11 ++++- yesod-routes/yesod-routes.cabal | 4 +- 4 files changed, 79 insertions(+), 5 deletions(-) create mode 100644 yesod-routes/Yesod/Routes/TH/Simple.hs diff --git a/yesod-routes/Yesod/Routes/TH/Simple.hs b/yesod-routes/Yesod/Routes/TH/Simple.hs new file mode 100644 index 00000000..f589b367 --- /dev/null +++ b/yesod-routes/Yesod/Routes/TH/Simple.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} +module Yesod.Routes.TH.Simple where + +import Yesod.Routes.TH +import Language.Haskell.TH.Syntax +import Web.PathPieces +import Data.Maybe (mapMaybe) +import Control.Monad (forM) +import Data.List (foldl') +import Data.ByteString (ByteString) + +mkSimpleDispatchClauses :: MkDispatchSettings -> [ResourceTree a] -> Q [Clause] +mkSimpleDispatchClauses MkDispatchSettings {..} (flatten -> resources) = do + clauses <- mapM go resources + clause404 <- mkClause404 + return $ clauses ++ [clause404] + where + go (FlatResource _ name pieces dispatch) = do + let env = VarE $ mkName "env" + req = VarE $ mkName "req" + gpi <- mdsGetPathInfo + gm <- mdsMethod + let handlePiece (_, Static str) = return (LitP $ StringL str, Nothing) + handlePiece (_, Dynamic _) = do + x <- newName "x" + let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + return (pat, Just x) + pairs <- mapM handlePiece pieces + let pats = map fst pairs + names = mapMaybe snd pairs + runHandler <- mdsRunHandler + let route = foldl' AppE (ConE (mkName name)) (map VarE names) + exp <- case dispatch of + Methods _ [] -> error "no methods" + Methods _ methods -> do + matches <- forM methods $ \method -> do + handler' <- mdsGetHandler (Just method) name + let handler = foldl' AppE handler' (map VarE names) + let body = NormalB exp + jroute = ConE 'Just `AppE` route + exp = runHandler `AppE` handler `AppE` env `AppE` jroute `AppE` req + return $ Match (LitP $ StringL method) body [] + let method = SigE (gm `AppE` req) (ConT ''ByteString) + return $ CaseE method matches + return $ Clause + [ VarP $ mkName "env" + , AsP (mkName "req") (ViewP gpi (ListP pats)) + ] (NormalB exp) [] + + mkClause404 = do + handler <- mds404 + runHandler <- mdsRunHandler + let exp = runHandler `AppE` handler `AppE` VarE (mkName "env") `AppE` ConE 'Nothing `AppE` VarE (mkName "req") + return $ Clause + [ VarP (mkName "env") + , VarP (mkName "req") + ] (NormalB exp) [] diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index c3c786c8..93eb15db 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/yesod-routes/test/Hierarchy.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,6 +28,9 @@ import qualified Yesod.Routes.Class as YRC import Data.Text (Text, pack, unpack, append) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 +#if SIMPLE_DISPATCH +import Yesod.Routes.TH.Simple +#endif class ToText a where toText :: a -> Text @@ -108,7 +112,11 @@ do rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources - dispatch <- mkDispatchClause MkDispatchSettings +#if SIMPLE_DISPATCH + dispatch <- mkSimpleDispatchClauses MkDispatchSettings +#else + dispatch <- fmap return $ mkDispatchClause MkDispatchSettings +#endif { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch|] , mdsGetPathInfo = [|fst|] @@ -124,7 +132,7 @@ do (ConT ''Dispatcher `AppT` ConT ''Hierarchy `AppT` ConT ''Hierarchy) - [FunD (mkName "dispatcher") [dispatch]] + [FunD (mkName "dispatcher") dispatch] : prinst : rrinst diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index efc996f7..afcceb90 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -24,6 +24,9 @@ import Language.Haskell.TH.Syntax import Hierarchy import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as Set +#if SIMPLE_DISPATCH +import Yesod.Routes.TH.Simple +#endif result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts @@ -125,7 +128,11 @@ do rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress prinst <- mkParseRouteInstance (ConT ''MyApp) ress - dispatch <- mkDispatchClause MkDispatchSettings +#if SIMPLE_DISPATCH + dispatch <- mkSimpleDispatchClauses MkDispatchSettings +#else + dispatch <- fmap return $ mkDispatchClause MkDispatchSettings +#endif { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch dispatcher|] , mdsGetPathInfo = [|fst|] @@ -141,7 +148,7 @@ do (ConT ''Dispatcher `AppT` ConT ''MyApp `AppT` ConT ''MyApp) - [FunD (mkName "dispatcher") [dispatch]] + [FunD (mkName "dispatcher") dispatch] : prinst : rainst : rrinst diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 65b1511a..bf0f3a8a 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -1,5 +1,5 @@ name: yesod-routes -version: 1.2.0.6 +version: 1.2.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -21,9 +21,11 @@ library , containers >= 0.2 , template-haskell , path-pieces >= 0.1 && < 0.2 + , bytestring exposed-modules: Yesod.Routes.Dispatch Yesod.Routes.TH + Yesod.Routes.TH.Simple Yesod.Routes.Class Yesod.Routes.Parse Yesod.Routes.Overlap