Incomplete changes

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) []

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
 

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

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 <michael@snoyman.com>
@@ -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