Harness.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeApplications #-}
-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.
module Generated.AggregateScalarExpressions.ScalarAccount.Harness (harnessAssertions) where

import Generated.AggregateScalarExpressions.ScalarAccount.Domain
import Generated.AggregateScalarExpressions.ScalarAccount.Codec (encodeScalarAccountEvent, parseScalarAccountEvent, scalarAccountCodec, encodeLimitsMapped, decodeLimitsMapped)
import Generated.AggregateScalarExpressions.ScalarAccount.Transducer (scalarAccountTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, fieldWitnessAgrees, (!))
import Keiro.Codec (eventType)
import Generated.AggregateScalarExpressions.Nominals (AccountMode (..), RequestId (..))
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as AesonKey
import Data.Aeson.KeyMap qualified as AesonKeyMap
import Data.Either (isLeft, isRight)
import Data.List (nub)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (isJust, isNothing)
import Data.Proxy (Proxy (..))
import Data.Text qualified as T
import Keiki.Shape (CanonicalTypeName (..))
import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)
import ScalarExpressions.Bindings qualified
import Generated.AggregateScalarExpressions.Structural.Shape.Limits qualified
import ScalarExpressions.Domain qualified
import Generated.AggregateScalarExpressions.StructuralProjections qualified as StructuralProjections
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime(..), picosecondsToDiffTime)

{- | (label, passed). A driver runs these and exits non-zero on any False,
naming the failing assertion. Filling a hole wrongly turns a specific
entry False; the scaffold cannot.
-}
harnessAssertions :: [(String, Bool)]
harnessAssertions =
  [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions scalarAccountTransducer))
  , ("clock-free: spec samples no wall clock", True)
  , ("golden round-trip: Adjusted", roundTrips sampleEventAdjusted)
  , ("golden round-trip: ClosedEvent", roundTrips sampleEventClosedEvent)
  , ("accepts Adjust from ScalarAccountOpen", acceptAdjust)
  ]
  ++ mappedConformanceAssertions
  ++ forwardReplayAdjust

roundTrips :: ScalarAccountEvent -> Bool
roundTrips e = parseScalarAccountEvent (eventType scalarAccountCodec e) (encodeScalarAccountEvent e) == Right e

sampleEventAdjusted :: ScalarAccountEvent
sampleEventAdjusted = (Adjusted (AdjustedData 0 0 0 "sample-label" False Normal (RequestId "sample") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) (snd (NonEmpty.head (fixtureCases ScalarExpressions.Bindings.limitsCases)))))

sampleEventClosedEvent :: ScalarAccountEvent
sampleEventClosedEvent = (ClosedEvent (ClosedEventData 0))

acceptAdjust :: Bool
acceptAdjust =
  case step scalarAccountTransducer (ScalarAccountOpen, initialScalarAccountRegs) ((Adjust (AdjustData 0 0 0 "sample-label" False Normal (RequestId "") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) (snd (NonEmpty.head (fixtureCases ScalarExpressions.Bindings.limitsCases)))))) of
    Just (v, _, _) -> v == ScalarAccountReviewed
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayAdjust :: [(String, Bool)]
forwardReplayAdjust =
  case step scalarAccountTransducer (ScalarAccountOpen, initialScalarAccountRegs) ((Adjust (AdjustData 0 0 0 "sample-label" False Normal (RequestId "") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) (snd (NonEmpty.head (fixtureCases ScalarExpressions.Bindings.limitsCases)))))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, forwardRegs, emitted) ->
      case mapM (\event -> parseScalarAccountEvent (eventType scalarAccountCodec event) (encodeScalarAccountEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither scalarAccountTransducer (ScalarAccountOpen, initialScalarAccountRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              , (prefix <> "register balance", (replayRegs ! #balance) == (forwardRegs ! #balance))
              , (prefix <> "register reserved", (replayRegs ! #reserved) == (forwardRegs ! #reserved))
              , (prefix <> "register capacity", (replayRegs ! #capacity) == (forwardRegs ! #capacity))
              , (prefix <> "register machine", (replayRegs ! #machine) == (forwardRegs ! #machine))
              , (prefix <> "register label", (replayRegs ! #label) == (forwardRegs ! #label))
              , (prefix <> "register active", (replayRegs ! #active) == (forwardRegs ! #active))
              , (prefix <> "register mode", (replayRegs ! #mode) == (forwardRegs ! #mode))
              , (prefix <> "register requestId", (replayRegs ! #requestId) == (forwardRegs ! #requestId))
              , (prefix <> "register openedAt", (replayRegs ! #openedAt) == (forwardRegs ! #openedAt))
              , (prefix <> "register limits", (replayRegs ! #limits) == (forwardRegs ! #limits))
              ]
  where
    prefix = "forward/replay equality: Adjust from ScalarAccountOpen -- "

mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
  concat
    [ limitsBindingAssertions
    , [("fixture coverage: scalar-expressions.Limits.v1", coverageLimits)]
    , adjustedLimitsAssertions
    , structuralWirePolicyAssertions
    , structuralProjectionAssertions
    ]

validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool
validFixtureLabels cases =
  all (not . T.null) labels && length labels == length (nub labels)
  where
    labels = map fst (NonEmpty.toList cases)

limitsBindingAssertions :: [(String, Bool)]
limitsBindingAssertions =
  ("fixture labels: scalar-expressions.Limits.v1", validFixtureLabels cases) :
  ("canonical identity: scalar-expressions.Limits.v1", canonicalTypeName (Proxy @ScalarExpressions.Domain.Limits) == "scalar-expressions.Limits.v1") :
  concat
    [ [ ("binding domain round-trip: scalar-expressions.Limits.v1/" <> T.unpack label, bindingDomainRoundTrip ScalarExpressions.Bindings.limitsBinding value)
      , ("binding shape round-trip: scalar-expressions.Limits.v1/" <> T.unpack label, bindingShapeRoundTrip ScalarExpressions.Bindings.limitsBinding (bindingToShape ScalarExpressions.Bindings.limitsBinding value))
      ]
    | (label, value) <- NonEmpty.toList cases
    ]
  where
    cases = fixtureCases ScalarExpressions.Bindings.limitsCases

coverageLimits :: Bool
coverageLimits = True

adjustedLimitsAssertions :: [(String, Bool)]
adjustedLimitsAssertions =
  [ ("mapped codec round-trip: Adjusted/limits/" <> T.unpack label, roundTrips (Adjusted (AdjustedData 0 0 0 "sample-label" False Normal (RequestId "sample") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases ScalarExpressions.Bindings.limitsCases)
  ]

structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
  [ ("wire policy unknown fields: scalar-expressions.Limits.v1", all (\(_, value) -> isLeft (decodeLimitsMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeLimitsMapped value)))) (NonEmpty.toList (fixtureCases ScalarExpressions.Bindings.limitsCases)))
  ]

structuralProjectionAssertions :: [(String, Bool)]
structuralProjectionAssertions =
  [ ("projection witness agreement: scalar-expressions.Limits.v1/ceiling", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.structuralProjectionC4cZC69ZC6dZC69ZC74ZC73ZC2fZC63ZC65ZC69ZC6cZC69ZC6eZC67ZWitness (\referenceOwner -> Generated.AggregateScalarExpressions.Structural.Shape.Limits.ceiling (bindingToShape ScalarExpressions.Bindings.limitsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases ScalarExpressions.Bindings.limitsCases)))
  , ("projection witness agreement: scalar-expressions.Limits.v1/minimum", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.structuralProjectionC4cZC69ZC6dZC69ZC74ZC73ZC2fZC6dZC69ZC6eZC69ZC6dZC75ZC6dZWitness (\referenceOwner -> Generated.AggregateScalarExpressions.Structural.Shape.Limits.minimum (bindingToShape ScalarExpressions.Bindings.limitsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases ScalarExpressions.Bindings.limitsCases)))
  ]

deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value
deleteObjectField key (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.delete (AesonKey.fromText key) objectValue)
deleteObjectField _ value = value

insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value
insertObjectField key inserted (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.insert (AesonKey.fromText key) inserted objectValue)
insertObjectField _ _ value = value

objectField :: T.Text -> Aeson.Value -> Maybe Aeson.Value
objectField key (Aeson.Object objectValue) = AesonKeyMap.lookup (AesonKey.fromText key) objectValue
objectField _ _ = Nothing