kleisli-0.0.1: benchmarks/Main.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -Werror #-}

module Main (main) where

import Control.Arrow (arr, (>>>))
import Control.Category ((.))
import Control.Comonad (duplicate, extract)
import Control.Monad ((>=>))
import Data.Functor.Apply ((<.>))
import Data.Functor.Bind ((>>-))
import Data.Functor.Contravariant (contramap)
import Data.Functor.Contravariant.Divisible (divide)
import Data.Functor.Identity (Identity (..))
import Data.Kleisli (ContraKleisli (..), Kleisli (..), ProKleisli (..))
import Data.Profunctor (dimap, lmap, rmap)
import Data.Semigroupoid (o)
import Test.Tasty.Bench (bench, bgroup, defaultMain, whnf)
import Prelude hiding ((.))

n :: Int
n = 1000

input :: Int
input = 42

kleisliFmap :: Int -> Kleisli (->) Int Maybe Int
kleisliFmap depth = iterate (fmap (+ 1)) (Kleisli Just) !! depth
{-# NOINLINE kleisliFmap #-}

rawFmap :: Int -> (Int -> Maybe Int)
rawFmap depth = iterate (\f x -> fmap (+ 1) (f x)) Just !! depth
{-# NOINLINE rawFmap #-}

kleisliApply :: Int -> Kleisli (->) Int Maybe Int
kleisliApply depth = iterate (\acc -> fmap (+) acc <.> Kleisli Just) (Kleisli Just) !! depth
{-# NOINLINE kleisliApply #-}

kleisliBind :: Int -> Kleisli (->) Int Maybe Int
kleisliBind depth = iterate (\acc -> acc >>- \x -> Kleisli (\_ -> Just (x + 1))) (Kleisli Just) !! depth
{-# NOINLINE kleisliBind #-}

rawBind :: Int -> (Int -> Maybe Int)
rawBind depth = iterate (\acc -> acc >=> \x -> Just (x + 1)) Just !! depth
{-# NOINLINE rawBind #-}

proKleisliCompose :: Int -> ProKleisli (->) Maybe Int Int
proKleisliCompose depth = iterate (\acc -> acc . ProKleisli (\x -> Just (x + 1))) (ProKleisli Just) !! depth
{-# NOINLINE proKleisliCompose #-}

proKleisliSemi :: Int -> ProKleisli (->) Maybe Int Int
proKleisliSemi depth = iterate (\acc -> acc `o` ProKleisli (\x -> Just (x + 1))) (ProKleisli Just) !! depth
{-# NOINLINE proKleisliSemi #-}

proKleisliArrow :: Int -> ProKleisli (->) Maybe Int Int
proKleisliArrow depth = iterate (\acc -> acc >>> arr (+ 1)) (ProKleisli Just) !! depth
{-# NOINLINE proKleisliArrow #-}

proKleisliLmap :: Int -> ProKleisli (->) Maybe Int Int
proKleisliLmap depth = iterate (lmap (+ 1)) (ProKleisli Just) !! depth
{-# NOINLINE proKleisliLmap #-}

rawLmap :: Int -> (Int -> Maybe Int)
rawLmap depth = iterate (\f x -> f (x + 1)) Just !! depth
{-# NOINLINE rawLmap #-}

proKleisliRmap :: Int -> ProKleisli (->) Maybe Int Int
proKleisliRmap depth = iterate (rmap (+ 1)) (ProKleisli Just) !! depth
{-# NOINLINE proKleisliRmap #-}

rawRmap :: Int -> (Int -> Maybe Int)
rawRmap depth = iterate (\f x -> fmap (+ 1) (f x)) Just !! depth
{-# NOINLINE rawRmap #-}

proKleisliDimap :: Int -> ProKleisli (->) Maybe Int Int
proKleisliDimap depth = iterate (dimap (+ 1) (+ 1)) (ProKleisli Just) !! depth
{-# NOINLINE proKleisliDimap #-}

rawDimap :: Int -> (Int -> Maybe Int)
rawDimap depth = iterate (\f x -> fmap (+ 1) (f (x + 1))) Just !! depth
{-# NOINLINE rawDimap #-}

contraKleisliContramap :: Int -> ContraKleisli (->) Int Identity Int
contraKleisliContramap depth = iterate (contramap (+ 1)) (ContraKleisli (Identity . (+ 1))) !! depth
{-# NOINLINE contraKleisliContramap #-}

rawContramap :: Int -> (Int -> Identity Int)
rawContramap depth = iterate (\f x -> f (x + 1)) (Identity . (+ 1)) !! depth
{-# NOINLINE rawContramap #-}

contraKleisliDivide :: Int -> ContraKleisli (->) Int [] Int
contraKleisliDivide depth =
  iterate (\acc -> divide (\x -> (x, x)) acc (ContraKleisli (\x -> [x + 1]))) (ContraKleisli (: [])) !! depth
{-# NOINLINE contraKleisliDivide #-}

kleisliComonad :: Int -> Kleisli (->) String ((,) String) Int
kleisliComonad depth = iterate (fmap (+ 1)) (Kleisli (\s -> (s, length s))) !! depth
{-# NOINLINE kleisliComonad #-}

rawExtract :: Int -> (String -> (String, Int))
rawExtract depth = iterate (\f s -> let (e, x) = f s in (e, x + 1)) (\s -> (s, length s)) !! depth
{-# NOINLINE rawExtract #-}

proKleisliComonad :: Int -> ProKleisli (->) ((,) String) String Int
proKleisliComonad depth = iterate (fmap (+ 1)) (ProKleisli (\s -> (s, length s))) !! depth
{-# NOINLINE proKleisliComonad #-}

main :: IO ()
main =
  defaultMain
    [ bgroup
        "Kleisli"
        [ bgroup
            "fmap"
            [ bench "newtype" $ whnf (\k -> let Kleisli f = k in f input) (kleisliFmap n),
              bench "raw" $ whnf (\f -> f input) (rawFmap n)
            ],
          bgroup
            "apply"
            [ bench "newtype" $ whnf (\k -> let Kleisli f = k in f input) (kleisliApply n)
            ],
          bgroup
            "bind"
            [ bench "newtype" $ whnf (\k -> let Kleisli f = k in f input) (kleisliBind n),
              bench "raw" $ whnf (\f -> f input) (rawBind n)
            ],
          bgroup
            "extract"
            [ bench "newtype" $ whnf extract (kleisliComonad n),
              bench "raw" $ whnf (\f -> snd (f "")) (rawExtract n)
            ],
          bgroup
            "duplicate"
            [ bench "newtype" $ whnf (\k -> let Kleisli f = duplicate k in f "") (kleisliComonad n)
            ]
        ],
      bgroup
        "ProKleisli"
        [ bgroup
            "category-compose"
            [ bench "newtype" $ whnf (\k -> let ProKleisli f = k in f input) (proKleisliCompose n),
              bench "raw" $ whnf (\f -> f input) (rawBind n)
            ],
          bgroup
            "semigroupoid-compose"
            [ bench "newtype" $ whnf (\k -> let ProKleisli f = k in f input) (proKleisliSemi n)
            ],
          bgroup
            "arrow-compose"
            [ bench "newtype" $ whnf (\k -> let ProKleisli f = k in f input) (proKleisliArrow n)
            ],
          bgroup
            "lmap"
            [ bench "newtype" $ whnf (\k -> let ProKleisli f = k in f input) (proKleisliLmap n),
              bench "raw" $ whnf (\f -> f input) (rawLmap n)
            ],
          bgroup
            "rmap"
            [ bench "newtype" $ whnf (\k -> let ProKleisli f = k in f input) (proKleisliRmap n),
              bench "raw" $ whnf (\f -> f input) (rawRmap n)
            ],
          bgroup
            "dimap"
            [ bench "newtype" $ whnf (\k -> let ProKleisli f = k in f input) (proKleisliDimap n),
              bench "raw" $ whnf (\f -> f input) (rawDimap n)
            ],
          bgroup
            "extract"
            [ bench "newtype" $ whnf extract (proKleisliComonad n)
            ],
          bgroup
            "duplicate"
            [ bench "newtype" $ whnf (\k -> let ProKleisli f = duplicate k in f "") (proKleisliComonad n)
            ]
        ],
      bgroup
        "ContraKleisli"
        [ bgroup
            "contramap"
            [ bench "newtype" $ whnf (\k -> let ContraKleisli f = k in f input) (contraKleisliContramap n),
              bench "raw" $ whnf (\f -> f input) (rawContramap n)
            ],
          bgroup
            "divide"
            [ bench "newtype" $ whnf (\k -> let ContraKleisli f = k in f input) (contraKleisliDivide n)
            ]
        ]
    ]