effect-systems benchmark

EffectSystemsBenchmark.hs

{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeApplications, TypeOperators #-}
module Main (main) where

import Criterion (bench, bgroup, nf)
import Criterion.Main (defaultMain)

import qualified Control.Monad.Trans.Class as Transformers
import qualified Control.Monad.Trans.Reader as Transformers
import qualified Control.Monad.Trans.State as Transformers

import qualified Control.Monad.Reader as MTL
import qualified Control.Monad.State as MTL

import qualified Control.Monad.Freer as FreerSimple
import qualified Control.Monad.Freer.Reader as FreerSimple
import qualified Control.Monad.Freer.State as FreerSimple

import qualified Control.Effect as FusedEffects
import qualified Control.Effect.Reader as FusedEffects
import qualified Control.Effect.State as FusedEffects

import qualified Polysemy as Polysemy
import qualified Polysemy.Reader as Polysemy
import qualified Polysemy.State as Polysemy

--------------------------------------------------------------------------------
                        -- State Benchmarks --
--------------------------------------------------------------------------------

countDownByHand :: Int -> (Int, Int)
countDownByHand start = go (-1) start
  where
    go :: Int -> Int -> (Int, Int)
    go dx x = if x <= 0
              then (x, x)
              else go dx (x+dx)

countDownTransformers :: Int -> (Int, Int)
countDownTransformers start = flip Transformers.runReader (-1)
                            $ flip Transformers.runStateT start
                            $ go
  where
    go :: Transformers.StateT Int (Transformers.Reader Int) Int
    go = do
      dx <- Transformers.lift Transformers.ask
      x <- Transformers.get
      if x <= 0
      then pure x
      else do
        Transformers.put (x+dx)
        go

countDownMTL :: Int -> (Int, Int)
countDownMTL start = flip MTL.runReader (-1)
                   $ flip MTL.runStateT start
                   $ go
  where
    go :: ( MTL.MonadReader Int m
          , MTL.MonadState Int m
          )
       => m Int
    go = do
      dx <- MTL.ask
      x <- MTL.get
      if x <= 0
      then pure x
      else do
        MTL.put (x+dx)
        go

countDownFreerSimple :: Int -> (Int, Int)
countDownFreerSimple start = FreerSimple.run 
                           $ FreerSimple.runReader (-1 :: Int)
                           $ FreerSimple.runState start
                           $ go
  where
    go :: ( FreerSimple.Member (FreerSimple.Reader Int) r
          , FreerSimple.Member (FreerSimple.State Int) r
          )
       => FreerSimple.Eff r Int
    go = do
      dx <- FreerSimple.ask
      x <- FreerSimple.get
      if x <= 0
      then pure x
      else do
        FreerSimple.put (x+dx)
        go

countDownFusedEffects :: Int -> (Int, Int)
countDownFusedEffects start = FusedEffects.run
                            $ FusedEffects.runReader (-1 :: Int)
                            $ FusedEffects.runState start
                            $ go
  where
    go :: ( FusedEffects.Member (FusedEffects.Reader Int) sig
          , FusedEffects.Member (FusedEffects.State Int) sig
          , FusedEffects.Effect sig
          , FusedEffects.Carrier sig m
          , Monad m
          )
       => m Int
    go = do
      dx <- FusedEffects.ask
      x <- FusedEffects.get
      if x <= 0
      then pure x
      else do
        FusedEffects.put (x+dx)
        go

countDownPolysemy :: Int -> (Int, Int)
countDownPolysemy start = Polysemy.run 
                        $ Polysemy.runReader (-1 :: Int)
                        $ Polysemy.runState start
                        $ go
  where
    go :: ( Polysemy.Member (Polysemy.Reader Int) r
          , Polysemy.Member (Polysemy.State Int) r
          )
       => Polysemy.Semantic r Int
    go = do
      dx <- Polysemy.ask
      x <- Polysemy.get
      if x <= 0
      then pure x
      else do
        Polysemy.put (x+dx)
        go





main :: IO ()
main =
  defaultMain
    [ bgroup "Countdown Bench"
      [ bench "by-hand"       $ nf countDownByHand       10000
      , bench "transformers"  $ nf countDownTransformers 10000
      , bench "mtl"           $ nf countDownMTL          10000
      , bench "freer-simple"  $ nf countDownFreerSimple  10000
      , bench "fused-effects" $ nf countDownFusedEffects 10000
      , bench "polysemy"      $ nf countDownPolysemy     10000
      ]
    ]

results at https://gelisam.com/files/effect-systems-benchmark/benchmark-ghc-8.6.4.html