Derive.hs

-- | The benchmarks that compare generic instances with written ones.
module Yamlet.Bench.Derive
  ( checkDerived
  , deriveBenchmarks
  ) where

import Control.DeepSeq
import Control.Monad
import Data.ByteString qualified as BS
import Test.Tasty.Bench

import Yamlet
import Yamlet.Bench.Derive.Generic qualified as G
import Yamlet.Bench.Derive.Manual qualified as M

-- | Fail if the two versions of a type give different YAML.
checkDerived :: IO ()
checkDerived = do
  same "contents" G.mkX M.mkX
  same "flat" G.mkF M.mkF
  where
    same :: (ToYaml g, ToYaml m) => String -> (Int -> g) -> (Int -> m) -> IO ()
    same name mkG mkM =
      unless (encode (map mkG values) == encode (map mkM values)) $
        fail ("the generic and the written instances differ: " ++ name)

-- | The benchmarks of each format, grouped by the operation, so that the
-- times of the two versions are next to each other.
deriveBenchmarks :: Benchmark
deriveBenchmarks =
  bgroup
    "derive"
    [ format "contents" G.mkX M.mkX
    , format "flat" G.mkF M.mkF
    ]
  where
    format
      :: forall g m
       . (NFData g, FromYaml g, ToYaml g, NFData m, FromYaml m, ToYaml m)
      => String
      -> (Int -> g)
      -> (Int -> m)
      -> Benchmark
    format name mkG mkM =
      bgroup
        name
        [ bgroup
            "toYaml"
            [ bench "generic" $ nf toYaml gs
            , bench "manual" $ nf toYaml ms
            ]
        , bgroup
            "parseYaml"
            [ bench "generic" $ nf (runParser (parseYaml @[g])) yaml
            , bench "manual" $ nf (runParser (parseYaml @[m])) yaml
            ]
        , bgroup
            "encode"
            [ bench "generic" $ nf encode gs
            , bench "manual" $ nf encode ms
            ]
        , bgroup
            "decode"
            [ bench "generic" $ nf (either (error . show) id . decode @[g]) bs
            , bench "manual" $ nf (either (error . show) id . decode @[m]) bs
            ]
        ]
      where
        gs :: [g]
        gs = map mkG values

        ms :: [m]
        ms = map mkM values

        -- Both versions give the same YAML, see 'checkDerived'.
        yaml :: Node
        yaml = toYaml gs

        bs :: BS.ByteString
        bs = encode gs

values :: [Int]
values = [1 .. 1000]