Harness.hs

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

import Generated.BehaviorComplete.Journey.Domain
import Generated.BehaviorComplete.Journey.Codec (encodeJourneyEvent, parseJourneyEvent, journeyCodec, encodeStartPayloadMapped, decodeStartPayloadMapped)
import Generated.BehaviorComplete.Journey.Transducer (journeyTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, fieldWitnessAgrees, (!))
import Keiro.Codec (eventType)
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 BehaviorComplete.Bindings qualified
import Generated.BehaviorComplete.Structural.Shape.StartPayload qualified
import BehaviorComplete.Domain qualified
import Generated.BehaviorComplete.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 journeyTransducer))
  , ("clock-free: spec samples no wall clock", True)
  , ("golden round-trip: Started", roundTrips sampleEventStarted)
  , ("golden round-trip: DecisionRecorded", roundTrips sampleEventDecisionRecorded)
  , ("golden round-trip: Retired", roundTrips sampleEventRetired)
  , ("golden round-trip: RetirementAudited", roundTrips sampleEventRetirementAudited)
  , ("accepts Start from JourneyEmpty", acceptStart)
  ]
  ++ mappedConformanceAssertions
  ++ forwardReplayStart

roundTrips :: JourneyEvent -> Bool
roundTrips e = parseJourneyEvent (eventType journeyCodec e) (encodeJourneyEvent e) == Right e

sampleEventStarted :: JourneyEvent
sampleEventStarted = (Started (StartedData (RequestId "sample") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) 0 (snd (NonEmpty.head (fixtureCases BehaviorComplete.Bindings.startPayloadCases)))))

sampleEventDecisionRecorded :: JourneyEvent
sampleEventDecisionRecorded = (DecisionRecorded (DecisionRecordedData 0))

sampleEventRetired :: JourneyEvent
sampleEventRetired = (Retired (RetiredData 0))

sampleEventRetirementAudited :: JourneyEvent
sampleEventRetirementAudited = (RetirementAudited (RetirementAuditedData 0))

acceptStart :: Bool
acceptStart =
  case step journeyTransducer (JourneyEmpty, initialJourneyRegs) ((Start (StartData (RequestId "sample") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) 0 (snd (NonEmpty.head (fixtureCases BehaviorComplete.Bindings.startPayloadCases)))))) of
    Just (v, _, _) -> v == JourneyActive
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayStart :: [(String, Bool)]
forwardReplayStart =
  case step journeyTransducer (JourneyEmpty, initialJourneyRegs) ((Start (StartData (RequestId "sample") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) 0 (snd (NonEmpty.head (fixtureCases BehaviorComplete.Bindings.startPayloadCases)))))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, forwardRegs, emitted) ->
      case mapM (\event -> parseJourneyEvent (eventType journeyCodec event) (encodeJourneyEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither journeyTransducer (JourneyEmpty, initialJourneyRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              , (prefix <> "register lastAmount", (replayRegs ! #lastAmount) == (forwardRegs ! #lastAmount))
              ]
  where
    prefix = "forward/replay equality: Start from JourneyEmpty -- "

mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
  concat
    [ startPayloadBindingAssertions
    , [("fixture coverage: behavior-complete.StartPayload.v1", coverageStartPayload)]
    , startedDetailsAssertions
    , 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)

startPayloadBindingAssertions :: [(String, Bool)]
startPayloadBindingAssertions =
  ("fixture labels: behavior-complete.StartPayload.v1", validFixtureLabels cases) :
  ("canonical identity: behavior-complete.StartPayload.v1", canonicalTypeName (Proxy @BehaviorComplete.Domain.StartPayload) == "behavior-complete.StartPayload.v1") :
  concat
    [ [ ("binding domain round-trip: behavior-complete.StartPayload.v1/" <> T.unpack label, bindingDomainRoundTrip BehaviorComplete.Bindings.startPayloadBinding value)
      , ("binding shape round-trip: behavior-complete.StartPayload.v1/" <> T.unpack label, bindingShapeRoundTrip BehaviorComplete.Bindings.startPayloadBinding (bindingToShape BehaviorComplete.Bindings.startPayloadBinding value))
      ]
    | (label, value) <- NonEmpty.toList cases
    ]
  where
    cases = fixtureCases BehaviorComplete.Bindings.startPayloadCases

coverageStartPayload :: Bool
coverageStartPayload = any (isNothing . Generated.BehaviorComplete.Structural.Shape.StartPayload.note) shapes && any (isJust . Generated.BehaviorComplete.Structural.Shape.StartPayload.note) shapes
  where
    shapes = map (bindingToShape BehaviorComplete.Bindings.startPayloadBinding . snd) (NonEmpty.toList (fixtureCases BehaviorComplete.Bindings.startPayloadCases))

startedDetailsAssertions :: [(String, Bool)]
startedDetailsAssertions =
  [ ("mapped codec round-trip: Started/details/" <> T.unpack label, roundTrips (Started (StartedData (RequestId "sample") (UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)) 0 mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases BehaviorComplete.Bindings.startPayloadCases)
  ]

structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
  [ ("wire policy missing default: behavior-complete.StartPayload.v1/optional_note", case decodeStartPayloadMapped (deleteObjectField "optional_note" (encodeStartPayloadMapped (snd (NonEmpty.head (fixtureCases BehaviorComplete.Bindings.startPayloadCases))))) of Left _ -> False; Right decoded -> objectField "optional_note" (encodeStartPayloadMapped decoded) == Just (Aeson.Null))
  , ("wire policy explicit null: behavior-complete.StartPayload.v1/optional_note", isRight (decodeStartPayloadMapped (insertObjectField "optional_note" Aeson.Null (encodeStartPayloadMapped (snd (NonEmpty.head (fixtureCases BehaviorComplete.Bindings.startPayloadCases)))))))
  , ("wire policy unknown fields: behavior-complete.StartPayload.v1", all (\(_, value) -> isLeft (decodeStartPayloadMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeStartPayloadMapped value)))) (NonEmpty.toList (fixtureCases BehaviorComplete.Bindings.startPayloadCases)))
  ]

structuralProjectionAssertions :: [(String, Bool)]
structuralProjectionAssertions =
  [ ("projection witness agreement: behavior-complete.StartPayload.v1/display_label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.structuralProjectionC53ZC74ZC61ZC72ZC74ZC50ZC61ZC79ZC6cZC6fZC61ZC64ZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6cZC61ZC62ZC65ZC6cZWitness (\referenceOwner -> Generated.BehaviorComplete.Structural.Shape.StartPayload.label (bindingToShape BehaviorComplete.Bindings.startPayloadBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases BehaviorComplete.Bindings.startPayloadCases)))
  ]

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