benchmarking lens representations

LensBenchmark.hs

-- inspired by this twitter conversation: https://twitter.com/haskell_cat/status/1360005114430390279
-- 
-- summary:
--   * by hand is fastest, then with a getter/setter pair, then van Laarhoven, then profunctor optics.
--   * in every representation, ghc can optimize 'view' to be as fast as doing it by hand
--   * there are no representations in which ghc can similarly optimize 'set' or 'modify'
--
-- criterion report: http://gelisam.com/files/lens-benchmark/benchmark.html

{-# LANGUAGE RankNTypes, TupleSections #-}
module Main where

import Criterion.Main
import Data.Functor.Const
import Data.Functor.Identity
import Data.Profunctor
import Data.Profunctor.Strong


type Lens1 s t a b = (s -> a, s -> b -> t)
type Lens2 s t a b = forall f. Functor f => (a -> f b) -> (s -> f t)
type Lens3 s t a b = forall p. Strong p => p a b -> p s t

view1 :: Lens1 s t a b -> (s -> a)
view1 = fst

view2 :: Lens2 s t a b -> (s -> a)
view2 lens2 = getConst . lens2 Const

view3 :: Lens3 s t a b -> (s -> a)
view3 lens3 = fmap getConst $ runStar $ lens3 $ Star Const

set1 :: Lens1 s t a b -> s -> b -> t
set1 = snd

set2 :: Lens2 s t a b -> s -> b -> t
set2 lens2 s b = runIdentity . lens2 (\_ -> Identity b) $ s

set3 :: Lens3 s t a b -> s -> b -> t
set3 lens3 s b = lens3 (const b) s

modify1 :: Lens1 s t a b -> (a -> b) -> (s -> t)
modify1 (get, set) f s = set s (f (get s))

modify2 :: Lens2 s t a b -> (a -> b) -> (s -> t)
modify2 lens2 f = runIdentity . lens2 (Identity . f)

modify3 :: Lens3 s t a b -> (a -> b) -> (s -> t)
modify3 lens3 f = lens3 f

compose1 :: Lens1 s t u v -> Lens1 u v a b -> Lens1 s t a b
compose1 (getSU, setSTV) (getUA, setUVB)
  = ( getUA . getSU
    , \s b -> setSTV s (setUVB (getSU s) b)
    )

compose2 :: Lens2 s t u v -> Lens2 u v a b -> Lens2 s t a b
compose2 = (.)

compose3 :: Lens3 s t u v -> Lens3 u v a b -> Lens3 s t a b
compose3 = (.)

snd1 :: Lens1 (x, a) (x, b) a b
snd1 = (snd, \(x, _) b -> (x, b))

snd2 :: Lens2 (x, a) (x, b) a b
snd2 a2fb (x, a) = (x,) <$> a2fb a

snd3 :: Lens3 (x, a) (x, b) a b
snd3 = second'


type S = (Int, (Int, (Int, (Int, A))))
type T = (Int, (Int, (Int, (Int, B))))
type A = Int
type B = Int

fib :: Int -> Int
fib m | m < 0     = error "negative!"
      | otherwise = go m
  where
    go 0 = 0
    go 1 = 1
    go n = go (n-1) + go (n-2)

main :: IO ()
main = defaultMain
  [ bgroup "by hand" [ bench "view"   $ nf (\(_, (_, (_, (_, e)))) -> e) s
                     , bench "set"    $ nf (uncurry $ \(a, (b, (c, (d, _)))) e
                                                   -> (a, (b, (c, (d, e)))))
                                           (s, 6 :: Int)
                     , bench "modify" $ nf (uncurry $ \f (a, (b, (c, (d, e))))
                                                   -> (a, (b, (c, (d, f e)))))
                                           (succ, s)
                     ]
  , bgroup "(get,set)" [ bench "view"   $ nf (view1 l1) s
                       , bench "set"    $ nf (uncurry $ set1 l1) (s, 6)
                       , bench "modify" $ nf (uncurry $ modify1 l1) (succ, s)
                       ]
  , bgroup "van Laarhoven" [ bench "view" $ nf (view2 l2) s
                           , bench "set"    $ nf (uncurry $ set2 l2) (s, 6)
                           , bench "modify" $ nf (uncurry $ modify2 l2) (succ, s)
                           ]
  , bgroup "profunctor" [ bench "view"   $ nf (view3 l3) s
                        , bench "set"    $ nf (uncurry $ set3 l3) (s, 6)
                        , bench "modify" $ nf (uncurry $ modify3 l3) (succ, s)
                        ]
  ]
  where
    s :: S
    s = (1, (2, (3, (4, 5))))

    l1 :: Lens1 S T A B
    l1 = snd1 `compose1` snd1 `compose1` snd1 `compose1` snd1

    l2 :: Lens2 S T A B
    l2 = snd2 `compose2` snd2 `compose2` snd2 `compose2` snd2

    l3 :: Lens3 S T A B
    l3 = snd3 `compose3` snd3 `compose3` snd3 `compose3` snd3