8c042db · effects-benchmarks

effects-benchmarks.cabal+19−1

compare with master

unifiedsplit

@@ -1,6 +1,6 @@

1cabal-version: 1.12

2

3−-- This file has been generated from package.yaml by hpack version 0.34.2.

3+-- This file has been generated from package.yaml by hpack version 0.34.4.

4--

5-- see: https://github.com/sol/hpack

6

@@ -42,6 +42,24 @@ benchmark effects-benchmarks

42 hs-source-dirs:

43 instances

44 src

45+ default-extensions:

46+ DeriveAnyClass

47+ DeriveFunctor

48+ DeriveGeneric

49+ DerivingStrategies

50+ FlexibleInstances

51+ GADTs

52+ GeneralizedNewtypeDeriving

53+ KindSignatures

54+ MultiParamTypeClasses

55+ TypeOperators

56+ UndecidableInstances

57+ DataKinds

58+ FlexibleContexts

59+ TypeApplications

60+ LambdaCase

61+ ScopedTypeVariables

62+ DerivingStrategies

45 build-depends:

63 build-depends:

46 base

64 base

47 , extensible-effects

65 , extensible-effects

hie.yamldeleted−7

@@ -1,7 +0,0 @@

1−cradle:

2− stack:

3− - path: "./instances"

4− component: "effects-benchmarks:bench:effects-benchmarks"

5−

6− - path: "./src/Main.hs"

7− component: "effects-benchmarks:bench:effects-benchmarks"

instances/ExtEff/Bench.hs+9−8

@@ -1,15 +1,16 @@

1module ExtEff.Bench

2− ( countDownBench

2+ ( countDownBench,

3− , countDownExcBench

3+ countDownExcBench,

4− , httpBench

4+ httpBench,

5+ )

5− ) where

6+where

6

7

8+import Control.Eff

9+import Control.Eff.Exception

10+import Control.Eff.State.Strict

11+import ExtEff.HTTP

7import ExtEff.Stateful

12import ExtEff.Stateful

8import ExtEff.StatefulExcept

13import ExtEff.StatefulExcept

9−import ExtEff.HTTP

10−import Control.Eff.State.Strict

11−import Control.Eff.Exception

12−import Control.Eff

13

14

14countDownBench :: Int -> (Int, Int)

15countDownBench :: Int -> (Int, Int)

15countDownBench start = run . runState start $ countDownPut

16countDownBench start = run . runState start $ countDownPut

instances/ExtEff/HTTP.hs+7−9

@@ -1,22 +1,20 @@

1−{-# LANGUAGE DataKinds, TypeOperators, GADTs, FlexibleInstances, MultiParamTypeClasses #-}

2−

3module ExtEff.HTTP where

1module ExtEff.HTTP where

4

2

5import Control.Eff

3import Control.Eff

6import Control.Eff.Extend

4import Control.Eff.Extend

7−import Data.Function

8import Control.Monad

5import Control.Monad

6+import Data.Function

9

7

10type HttpM = Eff '[HTTP, Lift IO]

8type HttpM = Eff '[HTTP, Lift IO]

11

9

12data HTTP a where

10data HTTP a where

13 Open :: String -> HTTP ()

11 Open :: String -> HTTP ()

14 Close :: HTTP ()

12 Close :: HTTP ()

15− Post :: String -> HTTP String

13+ Post :: String -> HTTP String

16− HGet :: HTTP String

14+ HGet :: HTTP String

17

15

18open' :: String -> HttpM ()

16open' :: String -> HttpM ()

19−open' = send . Open

17+open' = send . Open

20

18

21close' :: HttpM ()

19close' :: HttpM ()

22close' = send Close

20close' = send Close

@@ -30,9 +28,9 @@ get' = send HGet

30instance Handle HTTP r b (Eff e b) where

28instance Handle HTTP r b (Eff e b) where

31 handle h q req = case req of

29 handle h q req = case req of

32 Open _s -> h (q ^$ ())

30 Open _s -> h (q ^$ ())

33− Close -> h (q ^$ ())

31+ Close -> h (q ^$ ())

34− Post s -> h (q ^$ ("posted " <> s))

32+ Post s -> h (q ^$ ("posted " <> s))

35− HGet -> h (q ^$ "contents")

33+ HGet -> h (q ^$ "contents")

36

34

37doHttp :: Eff (HTTP ': e) b -> Eff e b

35doHttp :: Eff (HTTP ': e) b -> Eff e b

38doHttp = fix (handle_relay pure)

36doHttp = fix (handle_relay pure)

instances/ExtEff/Stateful.hs−4

@@ -1,7 +1,3 @@

1−{-# LANGUAGE MonoLocalBinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE DataKinds, TypeApplications #-}

4−

5module ExtEff.Stateful where

1module ExtEff.Stateful where

6

2

7import Control.Eff

3import Control.Eff

instances/ExtEff/StatefulExcept.hs+1−4

@@ -1,11 +1,8 @@

1−{-# LANGUAGE MonoLocalBinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE TypeApplications, DataKinds #-}

4module ExtEff.StatefulExcept where

1module ExtEff.StatefulExcept where

5

2

6import Control.Eff

3import Control.Eff

7−import Control.Eff.State.Strict

8import Control.Eff.Exception

4import Control.Eff.Exception

5+import Control.Eff.State.Strict

9

6

10countDownExc :: (Member (State Int) r, Member (Exc String) r) => Eff r b

7countDownExc :: (Member (State Int) r, Member (Exc String) r) => Eff r b

11countDownExc = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)

8countDownExc = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)

instances/Freer/Bench.hs+9−8

@@ -1,15 +1,16 @@

1module Freer.Bench

2− ( countDownBench

2+ ( countDownBench,

3− , countDownExcBench

3+ countDownExcBench,

4− , httpBench

4+ httpBench,

5+ )

5− ) where

6+where

6

7

8+import Control.Monad.Freer

9+import Control.Monad.Freer.Error

10+import Control.Monad.Freer.State

11+import Freer.HTTP

7import Freer.Stateful

12import Freer.Stateful

8import Freer.StatefulExcept

13import Freer.StatefulExcept

9−import Freer.HTTP

10−import Control.Monad.Freer.State

11−import Control.Monad.Freer.Error

12−import Control.Monad.Freer

13

14

14countDownBench :: Int -> (Int, Int)

15countDownBench :: Int -> (Int, Int)

15countDownBench start = run . runState start $ countDownPut

16countDownBench start = run . runState start $ countDownPut

instances/Freer/HTTP.hs+12−12

@@ -1,20 +1,18 @@

1−{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}

2−

3module Freer.HTTP where

1module Freer.HTTP where

4

2

5−import Control.Monad.Freer

6import Control.Monad

3import Control.Monad

4+import Control.Monad.Freer

7

5

8type HttpM = Eff '[HTTP, IO]

6type HttpM = Eff '[HTTP, IO]

9

7

10data HTTP a where

8data HTTP a where

11 Open :: String -> HTTP ()

9 Open :: String -> HTTP ()

12 Close :: HTTP ()

10 Close :: HTTP ()

13− Post :: String -> HTTP String

11+ Post :: String -> HTTP String

14− HGet :: HTTP String

12+ HGet :: HTTP String

15

13

16open' :: String -> HttpM ()

14open' :: String -> HttpM ()

17−open' = send . Open

15+open' = send . Open

18

16

19close' :: HttpM ()

17close' :: HttpM ()

20close' = send Close

18close' = send Close

@@ -26,12 +24,14 @@ get' :: HttpM String

26get' = send HGet

24get' = send HGet

27

25

28doHttp :: Eff (HTTP ': e) b -> Eff e b

26doHttp :: Eff (HTTP ': e) b -> Eff e b

27+doHttp =

29−doHttp = interpret

28+ interpret

30− (\x -> case x of

29+ ( \x -> case x of

31− Open _ -> pure ()

30+ Open _ -> pure ()

32− Close -> pure ()

31+ Close -> pure ()

33− Post a -> pure ("posted" <> a)

32+ Post a -> pure ("posted" <> a)

34− HGet -> pure "gotten")

33+ HGet -> pure "gotten"

34+ )

35

36runHttp :: HttpM a -> IO a

37runHttp = runM . doHttp

instances/Freer/Stateful.hs−4

@@ -1,7 +1,3 @@

1−{-# LANGUAGE MonoLocalBinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE TypeApplications, DataKinds #-}

4−

5module Freer.Stateful where

1module Freer.Stateful where

6

2

7import Control.Monad.Freer

3import Control.Monad.Freer

instances/Freer/StatefulExcept.hs+4−4

@@ -1,10 +1,10 @@

1−{-# LANGUAGE TypeApplications, DataKinds #-}

2module Freer.StatefulExcept where

1module Freer.StatefulExcept where

3

2

4import Control.Monad.Freer

3import Control.Monad.Freer

5−import Control.Monad.Freer.State

6import Control.Monad.Freer.Error

4import Control.Monad.Freer.Error

5+import Control.Monad.Freer.State

7

6

8countDownExc :: Eff '[State Int, Error String] b

7countDownExc :: Eff '[State Int, Error String] b

9−countDownExc = go where

8+countDownExc = go

9+ where

10− go = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> go)

10+ go = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> go)

instances/Fused/Bench.hs+8−7

@@ -1,14 +1,15 @@

1module Fused.Bench

2− ( countDownBench

2+ ( countDownBench,

3− , countDownExcBench

3+ countDownExcBench,

4− , httpBench

4+ httpBench,

5+ )

5− ) where

6+where

6

7

8+import Control.Carrier.Error.Either

9+import Control.Carrier.State.Strict

10+import Fused.HTTP

7import Fused.Stateful

11import Fused.Stateful

8import Fused.StatefulExcept

12import Fused.StatefulExcept

9−import Fused.HTTP

10−import Control.Carrier.State.Strict

11−import Control.Carrier.Error.Either

12

13

13countDownBench :: Int -> (Int, Int)

14countDownBench :: Int -> (Int, Int)

14countDownBench start = run . runState start $ countDownPut

15countDownBench start = run . runState start $ countDownPut

instances/Fused/HTTP.hs+20−24

@@ -1,46 +1,42 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleInstances, GeneralizedNewtypeDeriving,

2− KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}

3−

4module Fused.HTTP where

1module Fused.HTTP where

5

2

6import Control.Algebra

3import Control.Algebra

7−import Control.Monad.IO.Class

8−import GHC.Generics (Generic1)

9import Control.Carrier.Lift

4import Control.Carrier.Lift

10import Control.Monad

5import Control.Monad

6+import Control.Monad.IO.Class

7+import Data.Functor

8+import GHC.Generics (Generic1)

11

9

12−newtype HttpC m a = HttpC { runHttpC :: m a }

10+newtype HttpC m a = HttpC {runHttpC :: m a}

13 deriving newtype (Applicative, Functor, Monad, MonadIO)

11 deriving newtype (Applicative, Functor, Monad, MonadIO)

14

12

15−data HTTP (m :: * -> *) k

13+data HTTP (m :: * -> *) k where

16− = Open String (m k)

14+ Open :: String -> HTTP m ()

17− | Close (m k)

15+ Close :: HTTP m ()

18− | Post String (String -> m k)

16+ Post :: String -> HTTP m String

19− | HGet (String -> m k)

17+ HGet :: HTTP m String

20− deriving stock (Functor, Generic1)

21− deriving anyclass (HFunctor, Effect)

22

18

23open' :: String -> HttpM ()

19open' :: String -> HttpM ()

24−open' s = send (Open s (pure ()))

20+open' s = send (Open s)

25

21

26close' :: HttpM ()

22close' :: HttpM ()

27−close' = send (Close (pure ()))

23+close' = send Close

28

24

29post' :: String -> HttpM String

25post' :: String -> HttpM String

30−post' s = send (Post s pure)

26+post' s = send (Post s)

31

27

32get' :: HttpM String

28get' :: HttpM String

33−get' = send (HGet pure)

29+get' = send HGet

34

30

35type HttpM = HttpC (LiftC IO)

31type HttpM = HttpC (LiftC IO)

36

32

37−instance (Effect sig, Algebra sig m) => Algebra (HTTP :+: sig) (HttpC m) where

33+instance (Algebra sig m) => Algebra (HTTP :+: sig) (HttpC m) where

38− alg (L act) = case act of

34+ alg hdl (L act) ctx = case act of

39− Open _ k -> k

35+ Open _ -> pure ctx

40− Close k -> k

36+ Close -> pure ctx

41− Post s k -> k ("posted " <> s)

37+ Post s -> pure $ ctx $> ("posted " <> s)

42− HGet k -> k "lmao"

38+ HGet -> pure $ ctx $> "lmao"

43− alg (R other) = HttpC (alg (handleCoercible other))

39+ alg hdl (R other) ctx = HttpC (alg (runHttpC . hdl) other ctx)

44

40

45runHttp :: HttpM a -> IO a

41runHttp :: HttpM a -> IO a

46runHttp = runM . runHttpC

42runHttp = runM . runHttpC

instances/Fused/Stateful.hs−2

@@ -1,5 +1,3 @@

1−{-# LANGUAGE TypeApplications #-}

2−

3module Fused.Stateful where

1module Fused.Stateful where

4

2

5import Control.Effect.State

3import Control.Effect.State

instances/Fused/StatefulExcept.hs−4

@@ -1,12 +1,8 @@

1−{-# LANGUAGE TypeApplications #-}

2−

3module Fused.StatefulExcept where

1module Fused.StatefulExcept where

4

2

5−

6import Control.Effect.Error

3import Control.Effect.Error

7import Control.Effect.State

4import Control.Effect.State

8

5

9−

10countDownExc :: (Has (State Int) sig m, Has (Error String) sig m) => m a

6countDownExc :: (Has (State Int) sig m, Has (Error String) sig m) => m a

11countDownExc =

7countDownExc =

12 get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)

8 get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)

instances/MTL/Bench.hs+8−7

@@ -1,14 +1,15 @@

1module MTL.Bench

2− ( countDownBench

2+ ( countDownBench,

3− , countDownExcBench

3+ countDownExcBench,

4− , httpBench

4+ httpBench,

5+ )

5− ) where

6+where

6

7

8+import Control.Monad.Except

9+import Control.Monad.State.Strict

10+import MTL.HTTP

7import MTL.Stateful

11import MTL.Stateful

8import MTL.StatefulExcept

12import MTL.StatefulExcept

9−import MTL.HTTP

10−import Control.Monad.State.Strict

11−import Control.Monad.Except

12

13

13countDownBench :: Int -> (Int, Int)

14countDownBench :: Int -> (Int, Int)

14countDownBench start = flip runState start $ countDownPut

15countDownBench start = flip runState start $ countDownPut

instances/MTL/HTTP.hs+7−9

@@ -1,5 +1,3 @@

1−{-# LANGUAGE GADTs, LambdaCase #-}

2−

3module MTL.HTTP where

1module MTL.HTTP where

4

2

5import Control.Applicative

3import Control.Applicative

@@ -18,7 +16,7 @@ instance Functor HttpM where

18 fmap = liftA

16 fmap = liftA

19

17

20instance Applicative HttpM where

18instance Applicative HttpM where

21− pure = Pure

19+ pure = Pure

22 (<*>) = ap

20 (<*>) = ap

23

21

24instance Monad HttpM where

22instance Monad HttpM where

@@ -38,13 +36,13 @@ open' = Open

38

36

39runHttp :: HttpM a -> IO a

37runHttp :: HttpM a -> IO a

40runHttp = \case

38runHttp = \case

41− Pure x -> pure x

39+ Pure x -> pure x

42− Lift m -> m

40+ Lift m -> m

43 Then x f -> runHttp x >>= runHttp . f

41 Then x f -> runHttp x >>= runHttp . f

44− Open _ -> pure ()

42+ Open _ -> pure ()

45− Shut -> pure ()

43+ Shut -> pure ()

46− Post s -> pure ("posted " <> s)

44+ Post s -> pure ("posted " <> s)

47− HGet -> pure "lmap"

45+ HGet -> pure "lmap"

48

46

49doHTTP :: Int -> HttpM Int

47doHTTP :: Int -> HttpM Int

50doHTTP n = do

48doHTTP n = do

instances/MTL/Stateful.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE FlexibleContexts #-}

2module MTL.Stateful where

1module MTL.Stateful where

3

2

4import Control.Monad.State.Class

3import Control.Monad.State.Class

instances/MTL/StatefulExcept.hs+1−2

@@ -1,8 +1,7 @@

1−{-# LANGUAGE FlexibleContexts #-}

2module MTL.StatefulExcept where

1module MTL.StatefulExcept where

3

2

4−import Control.Monad.State.Class

5import Control.Monad.Error.Class

3import Control.Monad.Error.Class

4+import Control.Monad.State.Class

6

5

7countDownExc :: (MonadState Int m, MonadError String m) => m a

6countDownExc :: (MonadState Int m, MonadError String m) => m a

8countDownExc = get >>= (\n -> if n <= 0 then throwError "what" else put (n - 1) *> countDownExc)

7countDownExc = get >>= (\n -> if n <= 0 then throwError "what" else put (n - 1) *> countDownExc)

instances/Poly/Bench.hs+7−6

@@ -1,15 +1,16 @@

1module Poly.Bench

2− ( countDownBench

2+ ( countDownBench,

3− , countDownExcBench

3+ countDownExcBench,

4− , httpBench

4+ httpBench,

5+ )

5− ) where

6+where

6

7

8+import Poly.HTTP

7import Poly.Stateful

9import Poly.Stateful

8import Poly.StatefulExcept

10import Poly.StatefulExcept

9−import Poly.HTTP

10−import Polysemy.State

11import Polysemy

12import Polysemy.Error

13+import Polysemy.State

13

14

14countDownBench :: Int -> (Int, Int)

15countDownBench :: Int -> (Int, Int)

15countDownBench start = run . runState start $ countDownPut

16countDownBench start = run . runState start $ countDownPut

instances/Poly/HTTP.hs+8−8

@@ -1,22 +1,22 @@

1−{-# LANGUAGE ScopedTypeVariables, DataKinds, TemplateHaskell, KindSignatures, GADTs, FlexibleContexts, TypeOperators, LambdaCase #-}

1+{-# LANGUAGE TemplateHaskell #-}

2

3module Poly.HTTP where

4

5−import Polysemy

6import Control.Monad

5import Control.Monad

6+import Polysemy

7

8type HttpM = Sem '[Http, Final IO]

9

10data Http (m :: * -> *) a where

11− HOpen :: String -> Http m ()

11+ HOpen :: String -> Http m ()

12 HClose :: Http m ()

13− HPost :: String -> Http m String

13+ HPost :: String -> Http m String

14− HGet :: Http m String

14+ HGet :: Http m String

15

16makeSem ''Http

17

18open' :: String -> HttpM ()

19−open' = hOpen

19+open' = hOpen

20

21close' :: HttpM ()

22close' = hClose

@@ -30,9 +30,9 @@ get' = hGet

30runHttp' :: Sem (Http ': r) a -> Sem r a

31runHttp' = interpret $ \case

32 HOpen _ -> pure ()

33− HClose -> pure ()

33+ HClose -> pure ()

34 HPost s -> pure ("posted " <> s)

35− HGet -> pure "contents"

35+ HGet -> pure "contents"

36

37runHttp :: HttpM a -> IO a

38runHttp = runFinal . runHttp'

instances/Poly/Stateful.hs−4

@@ -1,7 +1,3 @@

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE DataKinds, TypeApplications #-}

4−

5module Poly.Stateful where

1module Poly.Stateful where

6

2

7import Polysemy

3import Polysemy

instances/Poly/StatefulExcept.hs+1−4

@@ -1,11 +1,8 @@

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE TypeApplications, DataKinds #-}

4module Poly.StatefulExcept where

1module Poly.StatefulExcept where

5

2

6import Polysemy

3import Polysemy

7−import Polysemy.State

8import Polysemy.Error

4import Polysemy.Error

5+import Polysemy.State

9

6

10countDownExc :: (Member (State Int) r, Member (Error String) r) => Sem r a

7countDownExc :: (Member (State Int) r, Member (Error String) r) => Sem r a

11countDownExc = get @Int >>= (\n -> if n <= 0 then throw "what" else put @Int (n - 1) *> countDownExc)

8countDownExc = get @Int >>= (\n -> if n <= 0 then throw "what" else put @Int (n - 1) *> countDownExc)

instances/Shallow/Bench.hs+6−5

@@ -1,12 +1,13 @@

1module Shallow.Bench

2− ( countDownBench

2+ ( countDownBench,

3− , countDownExcBench

3+ countDownExcBench,

4− , httpBench

4+ httpBench,

5+ )

5− ) where

6+where

6

7

8+import Shallow.HTTP

7import Shallow.Stateful

9import Shallow.Stateful

8import Shallow.StatefulExcept

10import Shallow.StatefulExcept

9−import Shallow.HTTP

10

11

11countDownBench :: Int -> (Int, Int)

12countDownBench :: Int -> (Int, Int)

12countDownBench = countDownPut

13countDownBench = countDownPut

instances/Shallow/HTTP.hs+2−4

@@ -1,11 +1,9 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−

3module Shallow.HTTP where

1module Shallow.HTTP where

4

2

5import Control.Monad

3import Control.Monad

6

4

7−newtype HttpM a = HttpM { runHttp :: IO a}

5+newtype HttpM a = HttpM {runHttp :: IO a}

8− deriving (Applicative, Functor, Monad)

6+ deriving newtype (Applicative, Functor, Monad)

9

7

10get' :: HttpM String

8get' :: HttpM String

11get' = pure "lmao"

9get' = pure "lmao"

instances/Shallow/Stateful.hs+4−3

@@ -2,7 +2,7 @@ module Shallow.Stateful where

2

3import Control.Monad

4

5−newtype StateM a = StateM { unStateM :: Int -> (Int, a) }

5+newtype StateM a = StateM {unStateM :: Int -> (Int, a)}

6

7instance Functor StateM where

8 fmap f (StateM a) = StateM (\n -> fmap f (a n))

@@ -24,5 +24,6 @@ runStateful :: Int -> StateM a -> (Int, a)

24runStateful n (StateM f) = f $! n

25

26countDownPut :: Int -> (Int, Int)

27−countDownPut start = runStateful start go where

27+countDownPut start = runStateful start go

28+ where

28− go = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> go)

29+ go = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> go)

instances/Shallow/StatefulExcept.hs+10−8

@@ -1,10 +1,8 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−

3module Shallow.StatefulExcept where

1module Shallow.StatefulExcept where

4

2

5import Control.Monad

3import Control.Monad

6

4

7−newtype StateM a = StateM { unStateM :: Int -> Either String (Int, a) }

5+newtype StateM a = StateM {unStateM :: Int -> Either String (Int, a)}

8

6

9instance Functor StateM where

7instance Functor StateM where

10 fmap f (StateM a) = StateM (\n -> fmap (fmap f) (a n))

8 fmap f (StateM a) = StateM (\n -> fmap (fmap f) (a n))

@@ -14,9 +12,12 @@ instance Applicative StateM where

14 (<*>) = ap

12 (<*>) = ap

15

13

16instance Monad StateM where

14instance Monad StateM where

15+ (StateM a) >>= f =

16+ StateM

17− (StateM a) >>= f = StateM (\n -> case a n of

17+ ( \n -> case a n of

18− Left s -> Left s

18+ Left s -> Left s

19− Right (n', x) -> unStateM (f x) n')

19+ Right (n', x) -> unStateM (f x) n'

20+ )

20

21

21get :: StateM Int

22get :: StateM Int

22get = StateM (\n -> Right (n, n))

23get = StateM (\n -> Right (n, n))

@@ -31,5 +32,6 @@ runStatefulExcept :: Int -> StateM a -> Either String (Int, a)

31runStatefulExcept n (StateM f) = f $! n

32runStatefulExcept n (StateM f) = f $! n

32

33

33countDownExc :: Int -> Either String (Int, Int)

34countDownExc :: Int -> Either String (Int, Int)

34−countDownExc start = runStatefulExcept start go where

35+countDownExc start = runStatefulExcept start go

36+ where

35− go = get >>= (\n -> if n <= 0 then throw "what" else put (n - 1) *> go)

37+ go = get >>= (\n -> if n <= 0 then throw "what" else put (n - 1) *> go)

package.yaml+18

@@ -15,3 +15,21 @@ benchmarks:

15 source-dirs:

16 - instances

17 - src

18+ default-extensions:

19+ - DeriveAnyClass

20+ - DeriveFunctor

21+ - DeriveGeneric

22+ - DerivingStrategies

23+ - FlexibleInstances

24+ - GADTs

25+ - GeneralizedNewtypeDeriving

26+ - KindSignatures

27+ - MultiParamTypeClasses

28+ - TypeOperators

29+ - UndecidableInstances

30+ - DataKinds

31+ - FlexibleContexts

32+ - TypeApplications

33+ - LambdaCase

34+ - ScopedTypeVariables

35+ - DerivingStrategies

src/Main.hs+56−50

@@ -1,72 +1,78 @@

1+{-# LANGUAGE CPP #-}

1−{-# LANGUAGE FlexibleContexts, GADTs, CPP #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE GADTs #-}

2

4

3module Main where

5module Main where

4

6

7+import qualified ExtEff.Bench as ExtEff

8+import qualified Freer.Bench as Freer

9+import qualified Fused.Bench as Fused

5import Gauge (bench, bgroup, nf, nfAppIO)

10import Gauge (bench, bgroup, nf, nfAppIO)

6import Gauge.Main (defaultMain)

11import Gauge.Main (defaultMain)

7−import qualified Weigh

8−

9−import qualified Fused.Bench as Fused

10−import qualified Freer.Bench as Freer

11−import qualified Shallow.Bench as Shallow

12import qualified MTL.Bench as MTL

13import qualified Poly.Bench as Poly

14−import qualified ExtEff.Bench as ExtEff

14+import qualified Shallow.Bench as Shallow

15+import qualified Weigh

15

16

16wruns :: Int

17wruns :: Int

17wruns = 1

18wruns = 1

18

19

19runs :: Int

20runs :: Int

20−runs = 10000

21+runs = 100000

21

22

22main :: IO ()

23main :: IO ()

23main = do

24main = do

24 putStrLn "*** Time benchmarks ***"

25 putStrLn "*** Time benchmarks ***"

25 defaultMain

26 defaultMain

26− [

27+ [ bgroup

27− bgroup "Countdown"

28+ "Countdown"

28− [ bgroup "Put"

29+ [ bgroup

30+ "Put"

29− [ bench "fused-effects" (nf Fused.countDownBench runs)

31+ [ bench "fused-effects" (nf Fused.countDownBench runs),

30− , bench "mtl" (nf MTL.countDownBench runs)

32+ bench "mtl" (nf MTL.countDownBench runs),

31− , bench "polysemy" (nf Poly.countDownBench runs)

33+ bench "polysemy" (nf Poly.countDownBench runs),

32− , bench "freer-simple" (nf Freer.countDownBench runs)

34+ bench "freer-simple" (nf Freer.countDownBench runs),

33− , bench "extensible-effects" (nf ExtEff.countDownBench runs)

35+ bench "extensible-effects" (nf ExtEff.countDownBench runs),

34− , bench "shallow" (nf Shallow.countDownBench runs)

36+ bench "shallow" (nf Shallow.countDownBench runs)

37+ ],

38+ bgroup

39+ "Put+Exc"

40+ [ bench "fused-effects" (nf Fused.countDownExcBench runs),

41+ bench "mtl" (nf MTL.countDownExcBench runs),

42+ bench "polysemy" (nf Poly.countDownExcBench runs),

43+ bench "freer-simple" (nf Freer.countDownExcBench runs),

44+ bench "extensible-effects" (nf ExtEff.countDownExcBench runs),

45+ bench "shallow" (nf Shallow.countDownExcBench runs)

46+ ]

47+ ],

48+ bgroup

49+ "HTTP"

50+ [ bench "fused-effects" (nfAppIO Fused.httpBench runs),

51+ bench "polysemy" (nfAppIO Poly.httpBench runs),

52+ bench "extensible-effects" (nfAppIO ExtEff.httpBench runs),

53+ bench "Deep embedding" (nfAppIO MTL.httpBench runs),

54+ bench "Shallow embedding" (nfAppIO Shallow.httpBench runs),

55+ bench "freer-simple" (nfAppIO Freer.httpBench runs)

35 ]

56 ]

36− , bgroup "Put+Exc"

37− [ bench "fused-effects" (nf Fused.countDownExcBench runs)

38− , bench "mtl" (nf MTL.countDownExcBench runs)

39− , bench "polysemy" (nf Poly.countDownExcBench runs)

40− , bench "freer-simple" (nf Freer.countDownExcBench runs)

41− , bench "extensible-effects" (nf ExtEff.countDownExcBench runs)

42− , bench "shallow" (nf Shallow.countDownExcBench runs)

43− ]

44− ]

45− , bgroup "HTTP"

46− [ bench "fused-effects" (nfAppIO Fused.httpBench runs)

47− , bench "polysemy" (nfAppIO Poly.httpBench runs)

48− , bench "extensible-effects" (nfAppIO ExtEff.httpBench runs)

49− , bench "Deep embedding" (nfAppIO MTL.httpBench runs)

50− , bench "Shallow embedding" (nfAppIO Shallow.httpBench runs)

51− , bench "freer-simple" (nfAppIO Freer.httpBench runs)

52− ]

53 ]

57 ]

54

58

55 putStrLn "*** Space benchmarks (these will take some time to run) ***"

59 putStrLn "*** Space benchmarks (these will take some time to run) ***"

56 Weigh.mainWith $ do

60 Weigh.mainWith $ do

57− Weigh.wgroup "Countdown" $ sequence_

61+ Weigh.wgroup "Countdown" $

62+ sequence_

58− [ Weigh.func "fused-effects" Fused.countDownBench wruns

63+ [ Weigh.func "fused-effects" Fused.countDownBench wruns,

59− , Weigh.func "mtl" MTL.countDownBench wruns

64+ Weigh.func "mtl" MTL.countDownBench wruns,

60− , Weigh.func "polysemy" Poly.countDownBench wruns

65+ Weigh.func "polysemy" Poly.countDownBench wruns,

61− , Weigh.func "freer-simple" Freer.countDownBench wruns

66+ Weigh.func "freer-simple" Freer.countDownBench wruns,

62− , Weigh.func "extensible-effects" ExtEff.countDownBench wruns

67+ Weigh.func "extensible-effects" ExtEff.countDownBench wruns,

63− , Weigh.func "shallow" Shallow.countDownBench wruns

68+ Weigh.func "shallow" Shallow.countDownBench wruns

64− ]

69+ ]

65− Weigh.wgroup "Countdown + exc" $ sequence_

70+ Weigh.wgroup "Countdown + exc" $

71+ sequence_

66− [ Weigh.func "fused-effects" Fused.countDownExcBench wruns

72+ [ Weigh.func "fused-effects" Fused.countDownExcBench wruns,

67− , Weigh.func "mtl" MTL.countDownExcBench wruns

73+ Weigh.func "mtl" MTL.countDownExcBench wruns,

68− , Weigh.func "polysemy" Poly.countDownExcBench wruns

74+ Weigh.func "polysemy" Poly.countDownExcBench wruns,

69− , Weigh.func "freer-simple" Freer.countDownExcBench wruns

75+ Weigh.func "freer-simple" Freer.countDownExcBench wruns,

70− , Weigh.func "extensible-effects" ExtEff.countDownExcBench wruns

76+ Weigh.func "extensible-effects" ExtEff.countDownExcBench wruns,

71− , Weigh.func "shallow" Shallow.countDownExcBench wruns

77+ Weigh.func "shallow" Shallow.countDownExcBench wruns

72− ]

78+ ]

stack.yaml+9−4

@@ -17,7 +17,7 @@

17#

18# resolver: ./custom-snapshot.yaml

19# resolver: https://example.com/snapshots/2018-01-01.yaml

20−resolver: lts-16.18

20+resolver: lts-18.21

21

22# User packages to be built.

23# Various formats can be used as shown in the example below.

@@ -29,7 +29,7 @@ resolver: lts-16.18

29# - auto-update

30# - wai

31packages:

32−- .

32+ - .

33# Dependency packages to be pulled from upstream that are not in the resolver.

34# These entries can reference officially published versions as well as

35# forks / in-progress versions pinned to a git hash. For example:

@@ -39,8 +39,8 @@ packages:

39# - git: https://github.com/commercialhaskell/stack.git

40# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

41#

42−# extra-deps: []

42+extra-deps:

43−

43+ - fused-effects-1.1.1.1

44# Override default flag values for local packages and extra-deps

45# flags: {}

46

@@ -64,3 +64,8 @@ packages:

64#

65# Allow a newer minor version of GHC than the snapshot specifies

66# compiler-check: newer-minor

67+

68+ghc-options:

69+ "$everything": -O2

70+

71+rebuild-ghc-options: true