git.iko.soy/effects-benchmarks
on master help sign in
First four libraries.
commit938af840c5f8184d77672b6160ff0a6d587a5190 authorPatrick Thomson <patrickt@github.com> dateFri 12 Oct 2018, 17:49 (8 years ago) parente45d26d
10 files changed+401
compare with master
unifiedsplit
LICENSE+30 README.md+1 Setup.hs+2 effects-benchmarks.cabal+30 src/FreerSimple.hs+73 src/HigherOrder.hs+76 src/JVEffects.hs+72 src/MTL.hs+27 src/Main.hs+14 stack.yaml+76
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright Author name here (c) 2018
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Author name here nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.mdnew file+1
@@ -0,0 +1 @@
1+# effects-benchmarks
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
effects-benchmarks.cabalnew file+30
@@ -0,0 +1,30 @@
1+name: effects-benchmarks
2+version: 0.1.0.0
3+-- synopsis:
4+-- description:
5+homepage: https://github.com/githubuser/effects-benchmarks#readme
6+license: BSD3
7+license-file: LICENSE
8+author: Author name here
9+maintainer: example@example.com
10+copyright: 2018 Author name here
11+category: Web
12+build-type: Simple
13+cabal-version: >=1.10
14+extra-source-files: README.md
15+
16+executable effects-benchmarks
17+ hs-source-dirs: src
18+ main-is: Main.hs
19+ other-modules: HigherOrder
20+ , JVEffects
21+ , MTL
22+ , FreerSimple
23+ default-language: Haskell2010
24+ build-depends: base >= 4.7 && < 5
25+ , higher-order-effects
26+ , effects
27+ , gauge
28+ , mtl
29+ , freer-simple
30+ ghc-options: -Wall -Werror -O2
src/FreerSimple.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE TypeOperators, GADTs, FlexibleContexts, DataKinds #-}
2+
3+module FreerSimple (marks) where
4+
5+import Control.Monad
6+import Control.Monad.Freer
7+import Control.Monad.Freer.State
8+import Control.Monad.Freer.Error
9+import Gauge
10+
11+data HTTP a where
12+ Open :: String -> HTTP ()
13+ Close :: HTTP ()
14+ Post :: String -> HTTP String
15+ HGet :: HTTP String
16+
17+open' :: Member HTTP r => String -> Eff r ()
18+open' = send . Open
19+
20+close' :: Member HTTP r => Eff r ()
21+close' = send Close
22+
23+post' :: Member HTTP r => String -> Eff r String
24+post' = send . Post
25+
26+get' :: Member HTTP r => Eff r String
27+get' = send HGet
28+
29+runHTTP :: Eff (HTTP ': e) b -> Eff e b
30+runHTTP = interpret
31+ (\x -> case x of
32+ Open _ -> pure ()
33+ Close -> pure ()
34+ Post a -> pure a
35+ HGet -> pure "gotten")
36+
37+prog :: Member HTTP r => Eff r ()
38+prog = open' "cats" >> get' >> post' "cats" >> close'
39+
40+p :: Member HTTP r => Int -> Eff r ()
41+p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
42+
43+oneGet :: Int -> (Int, Int)
44+oneGet n = run (runState n get)
45+
46+countDown :: Int -> (Int,Int)
47+countDown start = run (runState start go)
48+ where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
49+
50+countDownExc :: Int -> Either String (Int,Int)
51+countDownExc start = run $ runError (runState start go)
52+ where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
53+
54+-- prog :: (Monad m, Member HTTP sig, Carrier sig m) => m ()
55+-- prog = open' "cats" >> get' >> post' "cats" >> close'
56+
57+-- p :: (Monad m, Member HTTP sig, Carrier sig m) => Int -> m ()
58+-- p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
59+
60+marks :: Benchmark
61+marks = bgroup "freer-simple"
62+ [ bgroup "State"
63+ [ bench "get" $ whnf oneGet 0
64+ , bench "countdown" $ whnf countDown 100
65+ ]
66+ , bgroup "State + Error"
67+ [ bench "countdownExc" $ whnf countDownExc 10000
68+ ]
69+ , bgroup "HTTP DSL"
70+ [ bench "simple" $ whnf (run . runHTTP) prog
71+ , bench "replicated" $ whnf (run . runHTTP . p) 100000
72+ ]
73+ ]
src/HigherOrder.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses,
2+ TypeApplications, TypeOperators, UndecidableInstances #-}
3+
4+module HigherOrder (marks) where
5+
6+import Control.Effect
7+import Control.Monad
8+import Data.Coerce
9+import Gauge.Main
10+
11+data HTTP (m :: * -> *) k
12+ = Open String k
13+ | Close k
14+ | Post String (String -> k)
15+ | HGet (String -> k)
16+ deriving Functor
17+
18+instance HFunctor HTTP where
19+ hmap _ = coerce
20+
21+open' :: (Member HTTP sig, Carrier sig m) => String -> m ()
22+open' s = send (Open s (gen ()))
23+
24+close' :: (Member HTTP sig, Carrier sig m) => m ()
25+close' = send (Close (gen ()))
26+
27+post' :: (Member HTTP sig, Carrier sig m) => String -> m String
28+post' s = send (Post s gen)
29+
30+get' :: (Member HTTP sig, Carrier sig m) => m String
31+get' = send (HGet gen)
32+
33+newtype HTTPC m a = HTTPC { runHTTPC :: m a }
34+
35+instance (Carrier sig m) => Carrier (HTTP :+: sig) (HTTPC m) where
36+ gen = HTTPC . gen
37+ alg = algS \/ (HTTPC . alg . handlePure runHTTPC) where
38+ algS (Open _ k) = k
39+ algS (Close k) = k
40+ algS (Post s k) = k s
41+ algS (HGet k) = k ""
42+
43+runHTTP :: (Carrier sig m) => Eff (HTTPC m) a -> m a
44+runHTTP = runHTTPC . interpret
45+
46+oneGet :: Int -> (Int, Int)
47+oneGet n = run (runState n get)
48+
49+countDown :: Int -> (Int,Int)
50+countDown start = run (runState start go)
51+ where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
52+
53+countDownExc :: Int -> Either String (Int,Int)
54+countDownExc start = run $ runError (runState start go)
55+ where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
56+
57+prog :: (Monad m, Member HTTP sig, Carrier sig m) => m ()
58+prog = open' "cats" >> get' >> post' "cats" >> close'
59+
60+p :: (Monad m, Member HTTP sig, Carrier sig m) => Int -> m ()
61+p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
62+
63+marks :: Benchmark
64+marks = bgroup "higher-order-effects"
65+ [ bgroup "State"
66+ [ bench "get" $ whnf oneGet 0
67+ , bench "countdown" $ whnf countDown 100
68+ ]
69+ , bgroup "State + Error"
70+ [ bench "countdownExc" $ whnf countDownExc 10000
71+ ]
72+ , bgroup "HTTP DSL"
73+ [ bench "simple" $ whnf (run . runHTTP) prog
74+ , bench "replicated" $ whnf (run . runHTTP . p) 100000
75+ ]
76+ ]
src/JVEffects.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE TypeApplications, KindSignatures, TypeOperators, GADTs, FlexibleContexts, DataKinds #-}
2+
3+module JVEffects (marks) where
4+
5+import Control.Monad
6+import Control.Monad.Effect
7+import Control.Monad.Effect.Exception
8+import Control.Monad.Effect.State
9+import Gauge
10+
11+oneGet :: Int -> (Int, Int)
12+oneGet n = run @Eff (runState n get)
13+
14+countDown :: Int -> (Int,Int)
15+countDown start = run @Eff (runState start go)
16+ where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
17+
18+countDownExc :: Int -> Either String (Int,Int)
19+countDownExc start = run @Eff $ runError (runState start go)
20+ where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
21+
22+data HTTP (m :: * -> *) out where
23+ Open :: String -> HTTP m ()
24+ Close :: HTTP m ()
25+ Post :: String -> HTTP m String
26+ HGet :: HTTP m String
27+
28+instance Effect HTTP where
29+ handleState _ _ _ = error "Rob said we didn't need this"
30+
31+instance PureEffect HTTP
32+
33+open' :: Member HTTP r => String -> Eff r ()
34+open' = send . Open
35+
36+close' :: Member HTTP r => Eff r ()
37+close' = send Close
38+
39+post' :: Member HTTP r => String -> Eff r String
40+post' = send . Post
41+
42+get' :: Member HTTP r => Eff r String
43+get' = send HGet
44+
45+runHTTP :: PureEffects e => Eff (HTTP ': e) b -> Eff e b
46+runHTTP = interpret
47+ (\x -> case x of
48+ Open _ -> pure ()
49+ Close -> pure ()
50+ Post a -> pure a
51+ HGet -> pure "gotten")
52+
53+prog :: Member HTTP r => Eff r ()
54+prog = open' "cats" >> get' >> post' "cats" >> close'
55+
56+p :: Member HTTP r => Int -> Eff r ()
57+p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
58+
59+marks :: Benchmark
60+marks = bgroup "joshvera/effects"
61+ [ bgroup "State"
62+ [ bench "get" $ whnf oneGet 0
63+ , bench "countdown" $ whnf countDown 100
64+ ]
65+ , bgroup "State + Error"
66+ [ bench "countdownExc" $ whnf countDownExc 10000
67+ ]
68+ , bgroup "HTTP DSL"
69+ [ bench "simple" $ whnf (run . runHTTP) prog
70+ , bench "replicated" $ whnf (run . runHTTP . p) 100000
71+ ]
72+ ]
src/MTL.hsnew file+27
@@ -0,0 +1,27 @@
1+module MTL (marks) where
2+
3+import qualified Control.Monad.State as MTL
4+import qualified Control.Monad.Except as MTL
5+import Gauge
6+
7+oneGet :: Int -> (Int, Int)
8+oneGet = MTL.runState MTL.get
9+
10+countDown :: Int -> (Int,Int)
11+countDown = MTL.runState go
12+ where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)
13+
14+countDownExc :: Int -> Either String (Int,Int)
15+countDownExc = MTL.runStateT go
16+ where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)
17+
18+marks :: Benchmark
19+marks = bgroup "MTL"
20+ [ bgroup "State"
21+ [ bench "get" $ whnf oneGet 0
22+ , bench "countdown" $ whnf countDown 100
23+ ]
24+ , bgroup "State + Error"
25+ [ bench "countdownExc" $ whnf countDownExc 10000
26+ ]
27+ ]
src/Main.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import qualified HigherOrder as HigherOrder
4+import qualified JVEffects as JVEffects
5+import qualified FreerSimple as FreerSimple
6+import qualified MTL as MTL
7+import Gauge.Main
8+
9+main :: IO ()
10+main = defaultMain [ HigherOrder.marks
11+ , JVEffects.marks
12+ , FreerSimple.marks
13+ , MTL.marks
14+ ]
stack.yamlnew file+76
@@ -0,0 +1,76 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+# resolver: ghcjs-0.1.0_ghc-7.10.2
15+#
16+# The location of a snapshot can be provided as a file or url. Stack assumes
17+# a snapshot provided as a file might change, whereas a url resource does not.
18+#
19+# resolver: ./custom-snapshot.yaml
20+# resolver: https://example.com/snapshots/2018-01-01.yaml
21+resolver: lts-12.12
22+
23+# User packages to be built.
24+# Various formats can be used as shown in the example below.
25+#
26+# packages:
27+# - some-directory
28+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
29+# - location:
30+# git: https://github.com/commercialhaskell/stack.git
31+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
32+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
33+# subdirs:
34+# - auto-update
35+# - wai
36+packages:
37+- .
38+- location:
39+ git: https://github.com/robrix/higher-order-effects
40+ commit: 9426ca363e8bccfc7477de13d90fcdb07b11c012
41+ extra-dep: true
42+- location:
43+ git: https://github.com/joshvera/effects
44+ commit: fc7fc0e2896239a1fef3dbc40a76c131c42e0396
45+ extra-dep: true
46+
47+extra-deps:
48+ - type-aligned-0.9.6
49+# Dependency packages to be pulled from upstream that are not in the resolver
50+# using the same syntax as the packages field.
51+# (e.g., acme-missiles-0.3)
52+# extra-deps: []
53+
54+# Override default flag values for local packages and extra-deps
55+# flags: {}
56+
57+# Extra package databases containing global packages
58+# extra-package-dbs: []
59+
60+# Control whether we use the GHC we find on the path
61+# system-ghc: true
62+#
63+# Require a specific version of stack, using version ranges
64+# require-stack-version: -any # Default
65+# require-stack-version: ">=1.7"
66+#
67+# Override the architecture used by stack, especially useful on Windows
68+# arch: i386
69+# arch: x86_64
70+#
71+# Extra directories used by stack for building
72+# extra-include-dirs: [/path/to/dir]
73+# extra-lib-dirs: [/path/to/dir]
74+#
75+# Allow a newer minor version of GHC than the snapshot specifies
76+# compiler-check: newer-minor