Harness.hs

-- @generated by keiro-dsl 0.9.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.
module Generated.ImportPlanningCollisions.CollisionLedger.Harness (harnessAssertions) where

import Generated.ImportPlanningCollisions.CollisionLedger.Domain
import Generated.ImportPlanningCollisions.CollisionLedger.Codec (encodeCollisionLedgerEvent, parseCollisionLedgerEvent, collisionLedgerCodec, encodeDetailsMapped, decodeDetailsMapped)
import Generated.ImportPlanningCollisions.CollisionLedger.Transducer (collisionLedgerTransducer)
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.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 Generated.ImportPlanningCollisions.StructuralProjections qualified as StructuralProjections
import Data.List.NonEmpty qualified as NonEmpty
import Keiro.Codec.Nominal (nominalDomainRoundTrip, nominalFixtureCases, nominalFixtureDomain, nominalRepresentationRoundTrip, nominalToRepresentation)
import Generated.ImportPlanningCollisions.NominalProjections qualified as NominalProjections
import Generated.ImportPlanningCollisions.Structural.Shape.Details qualified as ShapeDetails
import ImportPlanning.Bindings qualified as Bindings
import ImportPlanning.Consumer.Domain qualified as Domain
import ImportPlanning.Consumer.Invoice.Types qualified as InvoiceTypes
import ImportPlanning.Consumer.Order.Types qualified as OrderTypes
import ImportPlanning.Consumer.Shared.Types (Details)

-- | (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 collisionLedgerTransducer))
  , ("clock-free: spec samples no wall clock", True)
  , ("golden round-trip: RecordedValues", roundTrips sampleEventRecordedValues)
  , ("accepts Record from CollisionLedgerEmpty", acceptRecord)
  ]
  ++ mappedConformanceAssertions
  ++ nominalConformanceAssertions
  ++ forwardReplayRecord

roundTrips :: CollisionLedgerEvent -> Bool
roundTrips e = parseCollisionLedgerEvent (eventType collisionLedgerCodec e) (encodeCollisionLedgerEvent e) == Right e

sampleEventRecordedValues :: CollisionLedgerEvent
sampleEventRecordedValues = (RecordedValues (RecordedValuesData (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.orderStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.invoiceStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.localCollisionFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.detailsFixtures)))))

acceptRecord :: Bool
acceptRecord =
  case step collisionLedgerTransducer (CollisionLedgerEmpty, initialCollisionLedgerRegs) ((Record (RecordData (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.orderStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.invoiceStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.localCollisionFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.detailsFixtures)))))) of
    Just (v, _, _) -> v == CollisionLedgerRecorded
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayRecord :: [(String, Bool)]
forwardReplayRecord =
  case step collisionLedgerTransducer (CollisionLedgerEmpty, initialCollisionLedgerRegs) ((Record (RecordData (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.orderStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.invoiceStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.localCollisionFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.detailsFixtures)))))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, _forwardRegs, emitted) ->
      case mapM (\event -> parseCollisionLedgerEvent (eventType collisionLedgerCodec event) (encodeCollisionLedgerEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither collisionLedgerTransducer (CollisionLedgerEmpty, initialCollisionLedgerRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, _replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              ]
  where
    prefix = "forward/replay equality: Record from CollisionLedgerEmpty -- "

mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
  concat
    [ detailsBindingAssertions
    , [("fixture coverage: import-planning.Details.v1", coverageDetails)]
    , recordedValuesDetailsAssertions
    , 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)

detailsBindingAssertions :: [(String, Bool)]
detailsBindingAssertions =
  ("fixture labels: import-planning.Details.v1", validFixtureLabels cases) :
  ("canonical identity: import-planning.Details.v1", canonicalTypeName (Proxy @Details) == "import-planning.Details.v1") :
  concat
    [ [ ("binding domain round-trip: import-planning.Details.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.detailsBinding value)
      , ("binding shape round-trip: import-planning.Details.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.detailsBinding (bindingToShape Bindings.detailsBinding value))
      ]
    | (label, value) <- NonEmpty.toList cases
    ]
  where
    cases = fixtureCases Bindings.detailsFixtures

coverageDetails :: Bool
coverageDetails = True

recordedValuesDetailsAssertions :: [(String, Bool)]
recordedValuesDetailsAssertions =
  [ ("mapped codec round-trip: RecordedValues/details/" <> T.unpack label, roundTrips (RecordedValues (RecordedValuesData (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.orderStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.invoiceStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.localCollisionFixtures))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.detailsFixtures)
  ]

structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
  [ ("wire policy unknown fields: import-planning.Details.v1", all (\(_, value) -> isLeft (decodeDetailsMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeDetailsMapped value)))) (NonEmpty.toList (fixtureCases Bindings.detailsFixtures)))
  ]

structuralProjectionAssertions :: [(String, Bool)]
structuralProjectionAssertions =
  [ ("projection witness agreement: import-planning.Details.v1/label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.detailsLabelWitness (\referenceOwner -> ShapeDetails.label (bindingToShape Bindings.detailsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.detailsFixtures)))
  ]

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

nominalConformanceAssertions :: [(String, Bool)]
nominalConformanceAssertions =
  [ ("nominal domain law: InvoiceStatus", all (\fixture -> nominalDomainRoundTrip Bindings.invoiceStatusBinding (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.invoiceStatusFixtures)))
  , ("nominal representation law: InvoiceStatus", all (\fixture -> let domainValue = nominalFixtureDomain fixture in nominalRepresentationRoundTrip Bindings.invoiceStatusBinding (nominalToRepresentation Bindings.invoiceStatusBinding domainValue)) (NonEmpty.toList (nominalFixtureCases Bindings.invoiceStatusFixtures)))
  , ("nominal projection agreement: InvoiceStatus", all (\fixture -> fieldWitnessAgrees NominalProjections.invoiceStatusWitness (nominalToRepresentation Bindings.invoiceStatusBinding) (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.invoiceStatusFixtures)))
  , ("nominal domain law: LocalCollision", all (\fixture -> nominalDomainRoundTrip Bindings.localCollisionBinding (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.localCollisionFixtures)))
  , ("nominal representation law: LocalCollision", all (\fixture -> let domainValue = nominalFixtureDomain fixture in nominalRepresentationRoundTrip Bindings.localCollisionBinding (nominalToRepresentation Bindings.localCollisionBinding domainValue)) (NonEmpty.toList (nominalFixtureCases Bindings.localCollisionFixtures)))
  , ("nominal projection agreement: LocalCollision", all (\fixture -> fieldWitnessAgrees NominalProjections.localCollisionWitness (nominalToRepresentation Bindings.localCollisionBinding) (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.localCollisionFixtures)))
  , ("nominal domain law: OrderStatus", all (\fixture -> nominalDomainRoundTrip Bindings.orderStatusBinding (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.orderStatusFixtures)))
  , ("nominal representation law: OrderStatus", all (\fixture -> let domainValue = nominalFixtureDomain fixture in nominalRepresentationRoundTrip Bindings.orderStatusBinding (nominalToRepresentation Bindings.orderStatusBinding domainValue)) (NonEmpty.toList (nominalFixtureCases Bindings.orderStatusFixtures)))
  , ("nominal projection agreement: OrderStatus", all (\fixture -> fieldWitnessAgrees NominalProjections.orderStatusWitness (nominalToRepresentation Bindings.orderStatusBinding) (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.orderStatusFixtures)))
  ]