Benchmark for the transient monad compared with others

Bench.hs

 --Based on https://gist.github.com/gelisam/be8ff8004cd701a084b6d64204a28bb6
{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeApplications, TypeOperators #-}

module Main (main) where


import qualified TransientCont as T      -- this file: https://gist.github.com/agocorona/2c9149c4d2035f21952fc1d1691b7bde
import Criterion (bench, bgroup, nf,whnfIO)

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 Transient.Internals

import Control.Applicative
import Data.Maybe(fromJust)

{-
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 --

--------------------------------------------------------------------------------


countDownStateIO :: Int -> IO (Maybe (Int, Int), EventF)
countDownStateIO start= runTransient $ noTrans go
   where 
    go :: StateIO (Int, Int)
    go = do
      let dx= -1
      x <- getData `onNothing` return start

      if x <= 0

      then pure $  (x,x)

      else do
        setData (x+dx)
        go 
        
-- countDownTransient :: Int -> IO (Maybe (Int, Int), EventF)
countDownTransient start= runTransient  go 

   where 
   go :: TransIO (Int, Int)
   go = do
      let dx= -1
      x <- getState <|> return start

      if x <= 0

      then pure (x,x)

      else do
        setState (x+dx)
        go 
 
 
countDownTransientCont :: Int -> IO ( (Int, Int), T.EventF) 
countDownTransientCont start= T.runTransient $ do 
   T.setState start
   go
   where 
   go :: T.TransIO (Int, Int)
   go = do
      let dx= -1
      x <- T.getState 

      if x <= 0

      then pure (x,x)

      else do
        T.setState (x+dx)
        go 
        

 
 
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       100000

      , bench "transformers"  $ nf countDownTransformers 100000

      , bench "mtl"           $ nf countDownMTL          100000
      
      , bench "transient"     $ whnfIO $ countDownTransient    100000
      
      , bench "stateIO"     $ whnfIO $ countDownStateIO    100000

      , bench "transientCont"     $ whnfIO $ countDownTransientCont    100000
{-
      , bench "freer-simple"  $ nf countDownFreerSimple  100000

      , bench "fused-effects" $ nf countDownFusedEffects 100000
-}
      , bench "polysemy"      $ nf countDownPolysemy     100000


      ]

    ]