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 + ]