From a83971c273c2766383b28c9d228eb646bdb79457 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 4 Mar 2014 14:09:12 +0200 Subject: [PATCH 1/2] Add some yesod-routes benchmarks --- .gitignore | 3 +- yesod-routes/bench/THHelper.hs | 24 +++++++++++ yesod-routes/bench/non-th.hs | 75 ++++++++++++++++++++++++++++++++++ yesod-routes/bench/th.hs | 68 ++++++++++++++++++++++++++++++ 4 files changed, 169 insertions(+), 1 deletion(-) create mode 100644 yesod-routes/bench/THHelper.hs create mode 100644 yesod-routes/bench/non-th.hs create mode 100644 yesod-routes/bench/th.hs diff --git a/.gitignore b/.gitignore index 205ace6b..2a3e8fac 100644 --- a/.gitignore +++ b/.gitignore @@ -11,7 +11,8 @@ yesod/foobar/ cabal.sandbox.config /vendor/ /.shelly/ -/tarballs/ +tarballs/ *.swp dist client_session_key.aes +.shelly/ diff --git a/yesod-routes/bench/THHelper.hs b/yesod-routes/bench/THHelper.hs new file mode 100644 index 00000000..6655da20 --- /dev/null +++ b/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 +|] diff --git a/yesod-routes/bench/non-th.hs b/yesod-routes/bench/non-th.hs new file mode 100644 index 00000000..97ef8c48 --- /dev/null +++ b/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 + ] diff --git a/yesod-routes/bench/th.hs b/yesod-routes/bench/th.hs new file mode 100644 index 00000000..dc937ac1 --- /dev/null +++ b/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 + ] From 5cb02e2a9b8339e0665a8f555ff37fccc3389106 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 4 Mar 2014 15:02:01 +0200 Subject: [PATCH 2/2] Minor tweaks --- yesod-core/yesod-core.cabal | 2 +- yesod-routes/Yesod/Routes/TH/Simple.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 7982fde0..3740f781 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 diff --git a/yesod-routes/Yesod/Routes/TH/Simple.hs b/yesod-routes/Yesod/Routes/TH/Simple.hs index 5af3c975..647e22ce 100644 --- a/yesod-routes/Yesod/Routes/TH/Simple.hs +++ b/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