Libraries.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

-- | The benchmarks that compare yamlet with the other libraries.
module Yamlet.Bench.Libraries
  ( libraryBenchmarks
  ) where

import Control.DeepSeq
import Data.Aeson qualified as J
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Map.Strict qualified as M
import Data.Text qualified as T
import Data.YAML qualified as H
import Data.YAML.Event qualified as HE
import Data.Yaml qualified as Y
import Test.Tasty.Bench

import Yamlet
import Yamlet.Bench.Inputs
import Yamlet.Bench.Types
import Yamlet.Syntax qualified as S

-- | The benchmarks are grouped by the operation, so that the times of the
-- libraries for one operation and input are next to each other.
libraryBenchmarks :: [Benchmark]
libraryBenchmarks =
  [ bgroup "parse" (map (uncurry parsing) inputs)
  , bgroup "render" (map (uncurry rendering) inputs)
  , bgroup
      "decode"
      [ decoding @[Config] "config" configInput []
      , decoding @[Json] "json" jsonInput [aesonDecoding @[Json] jsonInput]
      , decoding @(M.Map T.Text T.Text) "text" textInput []
      ]
  , bgroup
      "encode"
      [ encoding @[Config] "config" configInput []
      , encoding @[Json] "json" jsonInput [aesonEncoding @[Json] jsonInput]
      , encoding @(M.Map T.Text T.Text) "text" textInput []
      ]
  ]
  where
    -- The benchmarks that parse an input into the trees of each library.
    parsing :: String -> BS.ByteString -> Benchmark
    parsing name bs =
      bgroup
        name
        [ bgroup
            "yamlet"
            [ bench "syntax tree" $ nf S.parseDocuments bs
            , bench "values" $ nf (decodeAll @Value) bs
            ]
        , bgroup
            "HsYAML"
            [ bench "events" $ nf HE.parseEvents lazy
            , bench "nodes" $
                nf
                  ( foldMap (\(H.Doc n) -> forceNode n)
                      . either (error . show) id
                      . H.decodeNode
                  )
                  lazy
            ]
        , bgroup
            "yaml"
            [ bench "aeson value" $
                nf (either (error . show) id . Y.decodeEither' @J.Value) bs
            ]
        ]
      where
        lazy :: BL.ByteString
        lazy = BL.fromStrict bs

        -- HsYAML has no NFData instance for nodes.
        forceNode :: H.Node loc -> ()
        forceNode = \case
          H.Scalar _ s -> case s of
            H.SNull -> ()
            H.SBool b -> b `seq` ()
            H.SFloat d -> d `seq` ()
            H.SInt i -> i `seq` ()
            H.SStr t -> t `seq` ()
            H.SUnknown tag t -> tag `seq` t `seq` ()
          H.Mapping _ _ m -> foldMap (\(k, v) -> forceNode k `seq` forceNode v) (M.toList m)
          H.Sequence _ _ xs -> foldMap forceNode xs
          H.Anchor _ _ n -> forceNode n

    -- The benchmark that renders the syntax tree of an input.
    rendering :: String -> BS.ByteString -> Benchmark
    rendering name bs =
      bgroup name [bench "yamlet" $ nf (S.renderSyntax S.defaultRenderOptions) trees]
      where
        trees :: [S.Document]
        trees = either (error . show) id $ S.parseDocuments bs

    -- The benchmarks that decode an input into a value of the type, and the
    -- given benchmarks for other libraries.
    decoding
      :: forall a
       . (NFData a, FromYaml a, H.FromYAML a, J.FromJSON a)
      => String
      -> BS.ByteString
      -> [Benchmark]
      -> Benchmark
    decoding name bs others =
      bgroup name $
        [ bench "yamlet" $ nf (either (error . show) id . decode @a) bs
        , bench "HsYAML" $ nf (either (error . show) id . H.decode1Strict @a) bs
        , bench "yaml" $ nf (either (error . show) id . Y.decodeEither' @a) bs
        ]
          ++ others

    -- The benchmarks that encode the value of an input, decoded as the type,
    -- and the given benchmarks for other libraries.
    encoding
      :: forall a
       . (NFData a, FromYaml a, ToYaml a, H.ToYAML a, J.ToJSON a)
      => String
      -> BS.ByteString
      -> [Benchmark]
      -> Benchmark
    encoding name bs others =
      bgroup name $
        [ bench "yamlet" $ nf encode value
        , bench "HsYAML" $ nf H.encode1Strict value
        , bench "yaml" $ nf Y.encode value
        ]
          ++ others
      where
        value :: a
        value = either (error . show) id $ decode bs

    -- The benchmark that decodes a JSON input with aeson.
    aesonDecoding :: forall a. (NFData a, J.FromJSON a) => BS.ByteString -> Benchmark
    aesonDecoding bs = bench "aeson" $ nf (either error id . J.eitherDecodeStrict' @a) bs

    -- The benchmark that encodes the value of a JSON input as JSON with aeson.
    aesonEncoding
      :: forall a. (NFData a, FromYaml a, J.ToJSON a) => BS.ByteString -> Benchmark
    aesonEncoding bs = bench "aeson" $ nf J.encode value
      where
        value :: a
        value = either (error . show) id $ decode bs