git.iko.soy/effects-benchmarks
on master help sign in
add polysemy
commit2fca639c8ee4fac1e393e6e2b81ac1a51e403567 authorPatrick Thomson <patrickt@github.com> dateTue 30 Apr 2019, 16:58 (7 years ago) parente554963
7 files changed+114−6
compare with master
unifiedsplit
README.md−4 effects-benchmarks.cabal+11−1 instances/Freer/HTTP.hs+1−1 instances/Poly/HTTP.hs+61 instances/Poly/Stateful.hs+17 instances/Poly/StatefulExcept.hs+20 src/Main.hs+4
README.md−4
@@ -1,5 +1 @@
11# effects-benchmarks
2−
3−## Why Polysemy isn't on here
4−
5−There's a mysterious bug (possibly due to Backpack) where incorrect Core is generated when importing polysemy.
effects-benchmarks.cabal+11−1
@@ -13,7 +13,7 @@ extra-source-files: README.md
1313
1414common shared
1515 default-language: Haskell2010
16− ghc-options: -Wall -Werror -O1
16+ ghc-options: -Wall -Werror -O2
1717 build-depends: base >= 4.7 && < 5
1818
1919library benchmark-signatures
@@ -57,6 +57,14 @@ library instances-for-freer-simple
5757 , Freer.HTTP
5858 build-depends: freer-simple ^>= 1.2.1
5959
60+library instances-for-polysemy
61+ import: shared
62+ hs-source-dirs: instances
63+ exposed-modules: Poly.Stateful
64+ , Poly.StatefulExcept
65+ , Poly.HTTP
66+ build-depends: polysemy ^>= 0.1.2
67+
6068benchmark effects-benchmarks
6169 import: shared
6270 type: exitcode-stdio-1.0
@@ -65,6 +73,7 @@ benchmark effects-benchmarks
6573 , instances-for-mtl
6674 , instances-for-fused-effects
6775 , instances-for-freer-simple
76+ , instances-for-polysemy
6877 , instances-for-shallow
6978 , dump-core
7079 , gauge
@@ -74,3 +83,4 @@ benchmark effects-benchmarks
7483 , benchmark-signatures (Bench.Countdown as Fused.Countdown, Bench.HTTP as Fused.HTTPM) requires (Bench.Signature.Stateful as Fused.Stateful, Bench.Signature.StatefulExcept as Fused.StatefulExcept, Bench.Signature.HTTP as Fused.HTTP)
7584 , benchmark-signatures (Bench.Countdown as Simple.Countdown, Bench.HTTP as Simple.HTTPM) requires (Bench.Signature.Stateful as FSStateful, Bench.Signature.StatefulExcept as Freer.StatefulExcept, Bench.Signature.HTTP as Freer.HTTP)
7685 , benchmark-signatures (Bench.Countdown as Shallow.Countdown, Bench.HTTP as Shallow.HTTPM) requires (Bench.Signature.Stateful as Shallow.Stateful, Bench.Signature.StatefulExcept as Shallow.StatefulExcept, Bench.Signature.HTTP as Shallow.HTTP)
86+ , benchmark-signatures (Bench.Countdown as Poly.Countdown, Bench.HTTP as Poly.HTTPM) requires (Bench.Signature.Stateful as Poly.Stateful, Bench.Signature.StatefulExcept as Poly.StatefulExcept, Bench.Signature.HTTP as Poly.HTTP)
instances/Freer/HTTP.hs+1−1
@@ -29,7 +29,7 @@ doHttp = interpret
2929 (\x -> case x of
3030 Open _ -> pure ()
3131 Close -> pure ()
32− Post a -> pure a
32+ Post a -> pure ("posted" <> a)
3333 HGet -> pure "gotten")
3434
3535runHttp :: HttpM a -> IO a
instances/Poly/HTTP.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE DataKinds, TemplateHaskell, KindSignatures, GADTs, FlexibleContexts, TypeOperators, LambdaCase #-}
2+
3+module Poly.HTTP where
4+
5+import Polysemy
6+
7+type HttpM = Sem '[Http, Lift IO]
8+
9+data Http (m :: * -> *) a where
10+ HOpen :: String -> Http m ()
11+ HClose :: Http m ()
12+ HPost :: String -> Http m String
13+ HGet :: Http m String
14+
15+makeSem ''Http
16+
17+open' :: String -> HttpM ()
18+open' = hOpen
19+
20+close' :: HttpM ()
21+close' = hClose
22+
23+post' :: String -> HttpM String
24+post' = hPost
25+
26+get' :: HttpM String
27+get' = hGet
28+
29+runHttp' :: Sem (Http ': r) a -> Sem r a
30+runHttp' = interpret $ \case
31+ HOpen _ -> pure ()
32+ HClose -> pure ()
33+ HPost s -> pure ("posted " <> s)
34+ HGet -> pure "contents"
35+
36+runHttp :: HttpM a -> IO a
37+runHttp = runM . runHttp'
38+
39+-- open' :: String -> HttpM ()
40+-- open' = send . Open
41+
42+-- close' :: HttpM ()
43+-- close' = send Close
44+
45+-- post' :: String -> HttpM String
46+-- post' = send . Post
47+
48+-- get' :: HttpM String
49+-- get' = send Get
50+
51+-- runHttp' :: Eff (Http ': r) w -> Eff r w
52+-- runHttp' (Val x) = pure x
53+-- runHttp' (E u q) = case decomp u of
54+-- Right (Open _) -> runHttp (qApp q ())
55+-- Right Close -> runHttp (qApp q ())
56+-- Right (Post d) -> runHttp (qApp q d)
57+-- Right Get -> runHttp (qApp q "")
58+-- Left u' -> E u' (tsingleton (runHttp . qApp q ))
59+
60+-- runHttp :: HttpM a -> IO a
61+-- runHttp = runM . runHttp'
instances/Poly/Stateful.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE DataKinds, TypeApplications #-}
2+
3+module Poly.Stateful where
4+
5+import Polysemy
6+import Polysemy.State as State
7+
8+type StateM = Sem '[State Int]
9+
10+get :: StateM Int
11+get = State.get @Int
12+
13+put :: Int -> StateM ()
14+put = State.put @Int
15+
16+runStateful :: Int -> StateM a -> (Int, a)
17+runStateful n x = run $ State.runState n x
instances/Poly/StatefulExcept.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# LANGUAGE TypeApplications, DataKinds #-}
2+module Poly.StatefulExcept where
3+
4+import Polysemy
5+import Polysemy.State as State
6+import Polysemy.Error as Err
7+
8+type StateM = Sem '[State Int, Error String]
9+
10+get :: StateM Int
11+get = State.get @Int
12+
13+put :: Int -> StateM ()
14+put = State.put @Int
15+
16+throw :: String -> StateM a
17+throw = Err.throw
18+
19+runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
20+runStatefulExcept n x = run . runError $ State.runState n x
src/Main.hs+4
@@ -9,14 +9,17 @@ import qualified Fused.Countdown as Fused
99import qualified Simple.Countdown as Simple
1010import qualified Shallow.Countdown as Shallow
1111import qualified MTL.Countdown as MTL
12+import qualified Poly.Countdown as Poly
1213
1314import qualified Fused.HTTPM as Fused
1415import qualified Simple.HTTPM as Simple
1516import qualified MTL.HTTPM as MTL
1617import qualified Shallow.HTTPM as Shallow
18+import qualified Poly.HTTPM as Poly
1719
1820#define SUITE(nam,v) [ bench "fused-effects" (nf Fused.nam v) \
1921 , bench "mtl" (nf MTL.nam v) \
22+ , bench "polysemy" (nf Poly.nam v) \
2023 , bench "freer-simple" (nf Simple.nam v) \
2124 , bench "shallow" (nf Shallow.nam v) ]
2225
@@ -32,6 +35,7 @@ main = defaultMain
3235 ]
3336 , bgroup "HTTP"
3437 [ bench "fused-effects" (nfAppIO Fused.doHTTP runs)
38+ , bench "polysemy" (nfAppIO Poly.doHTTP runs)
3539 , bench "Deep embedding" (nfAppIO MTL.doHTTP runs)
3640 , bench "Shallow embedding" (nfAppIO Shallow.doHTTP runs)
3741 , bench "freer-simple" (nfAppIO Simple.doHTTP runs)