Bench.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

-- This module contains all definitions from the blogpost
-- "Lenses, do you get it?"

module Bench where

import DA.Record

-- Van Laarhoven lenses

type Lens r a = forall f. Functor f => (a -> f a) -> (r -> f r)

data Record = Record with field1: Int

_field1: Lens Record Int
_field1 f r = fmap (\x -> r with field1 = x) (f r.field1)

makeLens: (r -> a) -> (r -> a -> r) -> Lens r a
makeLens getter setter f r = setter r <$> f (getter r)

lens: forall x r a. HasField x r a => Lens r a
lens = makeLens (getField @x) (flip (setField @x))

-- Implementing the getter

data Const b a = Const with unConst: b

instance Functor (Const r) where
    fmap _ (Const x) = Const x

get: Lens s a -> s -> a
get l r = (l Const r).unConst

data Identity a = Identity with unIdentity: a

instance Functor Identity where
    fmap f (Identity x) = Identity (f x)

set: Lens s a -> a -> s -> s
set l x r = (l (\_ -> Identity x) r).unIdentity

-- How to micro-benchmark DAML

records = map Record [1..100_000]         -- (A)

benchLens = scenario do
    _ <- pure ()                          -- (B)
    let step acc r =
            acc + get (lens @"field1") r  -- (C)
    let _ = foldl step 0 records          -- (D)
    pure ()

numbers = [1..100_000]

benchNoop = scenario do
    _ <- pure ()
    let step acc r =
            acc + r
    let _ = foldl step 0 numbers
    pure ()

-- First numbers

benchBuiltin = scenario do
    _ <- pure ()
    let step acc r =
            acc + r.field1
    let _ = foldl step 0 records
    pure ()

-- Temporary stop-gap measures

fastLens: forall field r a. HasField field r a => Lens r a
fastLens f r = fmap (\x -> setField @field x r) (f (getField @field r))

benchFastLens = scenario do
    _ <- pure ()
    let step acc r =
            acc + get (fastLens @"field1") r
    let _ = foldl step 0 records
    pure ()