Main.hs

module Main (main) where

import Control.Exception (evaluate)
import Control.Monad (forM_, unless)
import Data.Text (Text)
import Data.Text qualified as Text
import Keiro.Dsl.Grammar (Spec (..))
import Keiro.Dsl.LanguageVersion (ParsedSource (..))
import Keiro.Dsl.Parser (parseSource, renderParseFailure)
import Keiro.Dsl.Scaffold (ScaffoldModule (..), defaultContext)
import Keiro.Dsl.ScaffoldRun (scaffoldServiceModules)
import Keiro.Dsl.SemanticContract (checkedSource)
import Keiro.Dsl.Validate (validateService)
import Test.Tasty.Bench (Benchmark, bench, defaultMain, whnf)

data Fixture = Fixture
  { dispatchCount :: !Int,
    parsedSource :: !ParsedSource,
    generatedBytes :: !Int
  }

main :: IO ()
main = do
  let fixtures = map fixture [8, 32, 128]
  forM_ fixtures $ \entry -> do
    _ <- evaluate entry.generatedBytes
    putStrLn
      ( "process-scaling dispatches="
          <> show entry.dispatchCount
          <> " generated-bytes="
          <> show entry.generatedBytes
      )
  forM_ (zip fixtures (drop 1 fixtures)) $ \(smaller, larger) ->
    unless (smaller.generatedBytes < larger.generatedBytes) $
      error "process-reaction generated bytes did not grow with dispatch count"
  defaultMain (map benchmark fixtures)

fixture :: Int -> Fixture
fixture count =
  let parsed = parseOrFail count (specification count)
      diagnostics = validateService (checkedSource parsed)
      bytes = scaffoldBytes parsed
   in if null diagnostics
        then Fixture count parsed bytes
        else error ("process-scaling validation failed: " <> show diagnostics)

benchmark :: Fixture -> Benchmark
benchmark entry =
  bench
    ( "dispatches-"
        <> show entry.dispatchCount
        <> "-bytes-"
        <> show entry.generatedBytes
    )
    (whnf scaffoldBytes entry.parsedSource)

parseOrFail :: Int -> Text -> ParsedSource
parseOrFail count source =
  case parseSource ("process-scaling-" <> show count <> ".keiro") source of
    Left failure -> error (Text.unpack (renderParseFailure failure))
    Right parsed -> parsed

scaffoldBytes :: ParsedSource -> Int
scaffoldBytes parsed =
  sum
    ( map
        (Text.length . (.text))
        ( scaffoldServiceModules
            (defaultContext parsed.spec.context)
            (checkedSource parsed)
        )
    )

specification :: Int -> Text
specification count =
  Text.unlines
    [ "language keiro-dsl 6",
      "context process-scaling",
      "",
      "id ThingId prefix=thing",
      "",
      "process FanOut",
      "  name \"fan-out\"",
      "  reactions version 1",
      "  input Triggered { thingId:ThingId }",
      "  correlate input.thingId via idText",
      "  saga Coordinator category \"coordinator\"",
      "  target Target",
      "  projections [ ]",
      "  on Triggered",
      "    advance Record { thingId }"
    ]
    <> Text.concat (replicate count dispatch)
    <> Text.unlines
      [ "  dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, targetStreamName, occurrence)",
        "  rejected => halt",
        "  poison => halt",
        "",
        "aggregate Coordinator",
        "  regs",
        "  states Open",
        "  command Record { thingId }",
        "  event Recorded = fields(Record)",
        "  Open -- Record --> emit Recorded ; goto Open",
        "",
        "aggregate Target",
        "  regs",
        "  states Open",
        "  command Touch { thingId }",
        "  event Touched = fields(Touch)",
        "  Open -- Touch --> emit Touched ; goto Open"
      ]
  where
    dispatch =
      Text.unlines
        [ "    dispatch Target@input.thingId Touch { thingId }",
          "      on-appended AckOk ; on-duplicate AckOk ; on-failed Retry"
        ]