Merge remote-tracking branch 'origin/simpler-dispatch' into persistent2-simpler-dispatch

.gitignore

@@ -11,7 +11,8 @@ yesod/foobar/
 cabal.sandbox.config
 /vendor/
 /.shelly/
-/tarballs/
+tarballs/
 *.swp
 dist
 client_session_key.aes
+.shelly/

yesod-core/yesod-core.cabal

@@ -25,7 +25,7 @@ extra-source-files:
 library
     build-depends:   base                  >= 4.3      && < 5
                    , time                  >= 1.1.4
-                   , yesod-routes          >= 1.2      && < 1.3
+                   , yesod-routes          >= 1.2.1    && < 1.3
                    , wai                   >= 1.4
                    , wai-extra             >= 1.3
                    , bytestring            >= 0.9.1.4

yesod-routes/Yesod/Routes/TH/Simple.hs

@@ -83,7 +83,7 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
         let restE = VarE restName
             restP = VarP restName
 
-        helperName <- newName "helper"
+        helperName <- newName $ "helper" ++ name
         let helperE = VarE helperName
 
         return $ Clause

yesod-routes/bench/THHelper.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+module THHelper where
+
+import Language.Haskell.TH.Syntax
+import Data.Char (toLower)
+import Yesod.Routes.TH
+import Yesod.Routes.Parse
+
+settings = MkDispatchSettings
+    [|\w x y z -> (w, x, y, z)|]
+    [|undefined|]
+    [|fst|]
+    [|\x (_, y) -> (x, y)|]
+    [|snd|]
+    [|Nothing|]
+    [|Nothing|]
+    (\(Just method) name -> return $ VarE $ mkName $ map toLower method ++ name)
+
+resources = [parseRoutes|
+/ HomeR GET
+/foo FooR GET
+/bar/#Int BarR GET
+/baz BazR GET
+|]

yesod-routes/bench/non-th.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Yesod.Routes.Dispatch
+import Data.Text (Text, words)
+import Prelude hiding (words)
+import Web.PathPieces
+import Criterion.Main
+import Control.DeepSeq
+import Control.Monad (forM_, unless)
+
+data TestRoute = Foo | Bar !Int | Baz
+    deriving Eq
+instance NFData TestRoute
+
+samples = take 10000 $ cycle
+    [ words "foo"
+    , words "foo bar"
+    , words ""
+    , words "bar baz"
+    , words "bar 4"
+    , words "bar 1234566789"
+    , words "baz"
+    , words "baz 4"
+    , words "something else"
+    ]
+
+simple :: [Text] -> Maybe TestRoute
+simple ["foo"] = Just Foo
+simple ["bar", x] = fmap Bar (fromPathPiece x)
+simple ["baz"] = Just Baz
+simple ["FOO"] = Just Foo
+simple ["BAR", x] = fmap Bar (fromPathPiece x)
+simple ["BAZ"] = Just Baz
+simple ["Foo"] = Just Foo
+simple ["Bar", x] = fmap Bar (fromPathPiece x)
+simple ["Baz"] = Just Baz
+simple ["Xfoo"] = Just Foo
+simple ["Xbar", x] = fmap Bar (fromPathPiece x)
+simple ["Xbaz"] = Just Baz
+simple ["XFOO"] = Just Foo
+simple ["XBAR", x] = fmap Bar (fromPathPiece x)
+simple ["XBAZ"] = Just Baz
+simple ["XFoo"] = Just Foo
+simple ["XBar", x] = fmap Bar (fromPathPiece x)
+simple ["XBaz"] = Just Baz
+simple _ = Nothing
+
+dispatch :: [Text] -> Maybe TestRoute
+dispatch = toDispatch
+    [ Route [Static "foo"] False (const (Just Foo))
+    , Route [Static "bar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
+    , Route [Static "baz"] False (const (Just Baz))
+    , Route [Static "FOO"] False (const (Just Foo))
+    , Route [Static "BAR", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
+    , Route [Static "BAZ"] False (const (Just Baz))
+    , Route [Static "Foo"] False (const (Just Foo))
+    , Route [Static "Bar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
+    , Route [Static "Baz"] False (const (Just Baz))
+    , Route [Static "Xfoo"] False (const (Just Foo))
+    , Route [Static "Xbar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
+    , Route [Static "Xbaz"] False (const (Just Baz))
+    , Route [Static "XFOO"] False (const (Just Foo))
+    , Route [Static "XBAR", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
+    , Route [Static "XBAZ"] False (const (Just Baz))
+    , Route [Static "XFoo"] False (const (Just Foo))
+    , Route [Static "XBar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
+    , Route [Static "XBaz"] False (const (Just Baz))
+    ]
+
+main :: IO ()
+main = do
+    forM_ samples $ \sample -> unless (simple sample == dispatch sample) (error $ show sample)
+    defaultMain
+        [ bench "simple" $ nf (map simple) samples
+        , bench "dispatch" $ nf (map dispatch) samples
+        ]

yesod-routes/bench/th.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, TupleSections, ViewPatterns #-}
+import Yesod.Routes.TH
+import Yesod.Routes.Parse
+import THHelper
+import Language.Haskell.TH.Syntax
+import Criterion.Main
+import Data.Text (words)
+import Prelude hiding (words)
+import Control.DeepSeq
+import Yesod.Routes.TH.Simple
+import Test.Hspec
+import Control.Monad (forM_, unless)
+
+$(do
+    let (cons, decs) = mkRouteCons $ map (fmap parseType) resources
+    clause1 <- mkDispatchClause settings resources
+    clause2 <- mkSimpleDispatchClause settings resources
+    return $ concat
+        [ [FunD (mkName "dispatch1") [clause1]]
+        , [FunD (mkName "dispatch2") [clause2]]
+        , decs
+        , [DataD [] (mkName "Route") [] cons [''Show, ''Eq]]
+        ]
+    )
+
+instance NFData Route where
+    rnf HomeR = ()
+    rnf FooR = ()
+    rnf (BarR i) = i `seq` ()
+    rnf BazR = ()
+
+getHomeR :: Maybe Int
+getHomeR = Just 1
+
+getFooR :: Maybe Int
+getFooR = Just 2
+
+getBarR :: Int -> Maybe Int
+getBarR i = Just (i + 3)
+
+getBazR :: Maybe Int
+getBazR = Just 4
+
+samples = take 10000 $ cycle
+    [ words "foo"
+    , words "foo bar"
+    , words ""
+    , words "bar baz"
+    , words "bar 4"
+    , words "bar 1234566789"
+    , words "baz"
+    , words "baz 4"
+    , words "something else"
+    ]
+
+dispatch2a = dispatch2 `asTypeOf` dispatch1
+
+main :: IO ()
+main = do
+    forM_ samples $ \sample ->
+        unless (dispatch1 True (sample, "GET") == dispatch2a True (sample, "GET"))
+            (error $ show sample)
+    defaultMain
+        [ bench "dispatch1" $ nf (map (dispatch1 True . (, "GET"))) samples
+        , bench "dispatch2" $ nf (map (dispatch2a True . (, "GET"))) samples
+        , bench "dispatch1a" $ nf (map (dispatch1 True . (, "GET"))) samples
+        , bench "dispatch2a" $ nf (map (dispatch2a True . (, "GET"))) samples
+        ]