diff --git a/bench/Core.hs b/bench/Core.hs new file mode 100644 index 0000000..73cbcf6 --- /dev/null +++ b/bench/Core.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +module Main where + +import Control.Monad +import Control.Monad.Freer +import Control.Monad.Freer.Internal +import Control.Monad.Freer.Exception +import Control.Monad.Freer.State +import Control.Monad.Freer.StateRW + +import Criterion +import Criterion.Main +import qualified Control.Monad.State as MTL +import qualified Control.Monad.Except as MTL +import qualified Control.Monad.Free as Free + +-------------------------------------------------------------------------------- + -- State Benchmarks -- +-------------------------------------------------------------------------------- +oneGet :: Int -> (Int, Int) +oneGet n = run (runState get n) + +countDown :: Int -> (Int,Int) +countDown start = run (runState go start) + where go = get >>= (\n -> if n <= 0 then return n else put (n-1) >> go) + +countDownRW :: Int -> (Int,Int) +countDownRW start = run (runStateR go start) + where go = ask >>= (\n -> if n <= 0 then return n else tell (n-1) >> go) + +countDownMTL :: Int -> (Int,Int) +countDownMTL = MTL.runState go + where go = MTL.get >>= (\n -> if n <= 0 then return n else MTL.put (n-1) >> go) + +-------------------------------------------------------------------------------- + -- Exception + State -- +-------------------------------------------------------------------------------- +countDownExc :: Int -> Either String (Int,Int) +countDownExc start = run $ runError (runState go start) + where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go) + +countDownExcMTL :: Int -> Either String (Int,Int) +countDownExcMTL = MTL.runStateT go + where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go) + +-------------------------------------------------------------------------------- + -- Freer: Interpreter -- +-------------------------------------------------------------------------------- +data Http out where + Open :: String -> Http () + Close :: Http () + Post :: String -> Http String + Get :: Http String + +open' :: Member Http r => String -> Eff r () +open' = send . Open + +close' :: Member Http r => Eff r () +close' = send Close + +post' :: Member Http r => String -> Eff r String +post' = send . Post + +get' :: Member Http r => Eff r String +get' = send Get + +runHttp :: Eff (Http ': r) w -> Eff r w +runHttp (Val x) = return x +runHttp (E u q) = case decomp u of + Right (Open _) -> runHttp (qApp q ()) + Right Close -> runHttp (qApp q ()) + Right (Post d) -> runHttp (qApp q d) + Right Get -> runHttp (qApp q "") + Left u' -> E u' (tsingleton (runHttp . qApp q )) + +-------------------------------------------------------------------------------- + -- Free: Interpreter -- +-------------------------------------------------------------------------------- +data FHttpT x + = FOpen String x + | FClose x + | FPost String (String -> x) + | FGet (String -> x) + deriving Functor + +type FHttp = Free.Free FHttpT + +fopen' :: String -> FHttp () +fopen' s = Free.liftF $ FOpen s () + +fclose' :: FHttp () +fclose' = Free.liftF $ FClose () + +fpost' :: String -> FHttp String +fpost' s = Free.liftF $ FPost s id + +fget' :: FHttp String +fget' = Free.liftF $ FGet id + +runFHttp :: FHttp a -> Maybe a +runFHttp (Free.Pure x) = return x +runFHttp (Free.Free (FOpen _ n)) = runFHttp n +runFHttp (Free.Free (FClose n)) = runFHttp n +runFHttp (Free.Free (FPost s n)) = pure s >>= runFHttp . n +runFHttp (Free.Free (FGet n)) = pure "" >>= runFHttp . n + +-------------------------------------------------------------------------------- + -- Benchmark Suite -- +-------------------------------------------------------------------------------- +prog :: Member Http r => Eff r () +prog = open' "cats" >> get' >> post' "cats" >> close' + +prog' :: FHttp () +prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose' + +p :: Member Http r => Int -> Eff r () +p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close' + +p' :: Int -> FHttp () +p' count = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose' + +main :: IO () +main = + defaultMain [ + bgroup "State" [ + bench "get" $ whnf oneGet 0 + ], + bgroup "Countdown Bench" [ + bench "freer.State" $ whnf countDown 10000 + , bench "freer.StateRW" $ whnf countDownRW 10000 + , bench "mtl.State" $ whnf countDownMTL 10000 + ], + bgroup "Countdown+Except Bench" [ + bench "freer.ExcState" $ whnf countDownExc 10000 + , bench "mtl.ExceptState" $ whnf countDownExcMTL 10000 + ], + bgroup "HTTP Simple DSL" [ + bench "freer" $ whnf (run . runHttp) prog + , bench "free" $ whnf runFHttp prog' + + , bench "freerN" $ whnf (run . runHttp . p) 100000 + , bench "freeN" $ whnf (runFHttp . p') 100000 + ] + ] diff --git a/changelog.md b/changelog.md index c09229c..01aba50 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +# 0.2.2.0 (Sep. 13, 2015) + +* Add bench suite + # 0.2.1.0 (Sep. 13, 2015) * Add test suite diff --git a/freer.cabal b/freer.cabal index ed8145b..6fc30a0 100644 --- a/freer.cabal +++ b/freer.cabal @@ -1,5 +1,5 @@ name: freer -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Implementation of the Freer Monad license: BSD3 license-file: LICENSE @@ -89,3 +89,16 @@ test-suite test , QuickCheck ghc-options: -Wall + +benchmark core + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Core.hs + build-depends: base + , freer + , criterion + , mtl + , free + + ghc-options: -Wall -O2