keiro-dsl-0.17.0.0: test/conformance-structural-nominals/Generated/StructuralNominalLeaves/TemplateCatalog/Harness.hs
{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl 0.17.0.0 (language keiro-dsl 6) from aggregate TemplateCatalog; do not edit.
module Generated.StructuralNominalLeaves.TemplateCatalog.Harness (harnessAssertions) where
import Generated.StructuralNominalLeaves.TemplateCatalog.Domain
import Generated.StructuralNominalLeaves.TemplateCatalog.Codec (encodeTemplateCatalogEvent, parseTemplateCatalogEvent, templateCatalogCodec, encodeTemplateBookMapped, decodeTemplateBookMapped, encodeTemplateRefMapped, decodeTemplateRefMapped, encodeTemplateStateMapped, decodeTemplateStateMapped)
import Generated.StructuralNominalLeaves.TemplateCatalog.Transducer (templateCatalogTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, fieldWitnessAgrees, (!))
import Keiro.Codec (eventType)
import Generated.StructuralNominalLeaves.Nominals (TemplateId, parseTemplateId)
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 Keiro.Codec.Structural (FixtureCases (..))
import Data.List.NonEmpty qualified as NonEmpty
import Keiro.Codec.Nominal (nominalDomainRoundTrip, nominalFixtureCases, nominalFixtureDomain, nominalRepresentationRoundTrip, nominalToRepresentation)
import Data.KindID qualified as KindID
import Data.Text qualified as T
import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)
import Generated.StructuralNominalLeaves.NominalProjections qualified as NominalProjections
import Conformance.StructuralNominals.Bindings qualified as Bindings
-- | (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 templateCatalogTransducer))
-- clock-free: spec samples no wall clock (verified at scaffold time)
, ("golden round-trip: TemplateRecorded", roundTrips sampleEventTemplateRecorded)
, ("golden round-trip: TemplateRouted", roundTrips sampleEventTemplateRouted)
, ("accepts RecordTemplate from TemplateCatalogEmpty", acceptRecordTemplate)
]
++ mappedConformanceAssertions
++ nominalConformanceAssertions
++ forwardReplayRecordTemplate
roundTrips :: TemplateCatalogEvent -> Bool
roundTrips e = parseTemplateCatalogEvent (eventType templateCatalogCodec e) (encodeTemplateCatalogEvent e) == Right e
sampleTemplateId :: TemplateId
sampleTemplateId =
case parseTemplateId "template_01h455vb4pex5vsknk084sn02q" of
Right parsed -> parsed
Left problem -> error (show problem)
sampleEventTemplateRecorded :: TemplateCatalogEvent
sampleEventTemplateRecorded = TemplateRecorded (TemplateRecordedData (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateRefFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateBookFixtures))))
sampleEventTemplateRouted :: TemplateCatalogEvent
sampleEventTemplateRouted = TemplateRouted (TemplateRoutedData sampleTemplateId (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.claimIdFixtures))))
acceptRecordTemplate :: Bool
acceptRecordTemplate =
case step templateCatalogTransducer (TemplateCatalogEmpty, initialTemplateCatalogRegs) (RecordTemplate (RecordTemplateData (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateRefFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateBookFixtures))))) of
Just (v, _, _) -> v == TemplateCatalogRecorded
Nothing -> False
-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayRecordTemplate :: [(String, Bool)]
forwardReplayRecordTemplate =
case step templateCatalogTransducer (TemplateCatalogEmpty, initialTemplateCatalogRegs) (RecordTemplate (RecordTemplateData (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateRefFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateBookFixtures))))) of
Nothing -> [(prefix <> "forward step accepted", False)]
Just (forwardVertex, forwardRegs, emitted) ->
case mapM (\event -> parseTemplateCatalogEvent (eventType templateCatalogCodec event) (encodeTemplateCatalogEvent event)) emitted of
Left _ -> [(prefix <> "emitted chain decodes", False)]
Right decodedEvents ->
case applyEventsEither templateCatalogTransducer (TemplateCatalogEmpty, initialTemplateCatalogRegs) decodedEvents of
Left _ -> [(prefix <> "replay succeeds", False)]
Right (replayVertex, replayRegs) ->
[ (prefix <> "final vertex", replayVertex == forwardVertex)
, (prefix <> "register book", (replayRegs ! #book) == (forwardRegs ! #book))
, (prefix <> "register activeTemplateId", (replayRegs ! #activeTemplateId) == (forwardRegs ! #activeTemplateId))
]
where
prefix = "forward/replay equality: RecordTemplate from TemplateCatalogEmpty -- "
mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
concat
[ templateRecordedStateAssertions
, templateRecordedReferenceAssertions
, templateRecordedBookAssertions
, structuralWirePolicyAssertions
]
templateRecordedStateAssertions :: [(String, Bool)]
templateRecordedStateAssertions =
[ ("mapped codec round-trip: TemplateRecorded/state/" <> T.unpack label, roundTrips (TemplateRecorded (TemplateRecordedData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.templateRefFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateBookFixtures))))))
| (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.templateStateFixtures)
]
templateRecordedReferenceAssertions :: [(String, Bool)]
templateRecordedReferenceAssertions =
[ ("mapped codec round-trip: TemplateRecorded/reference/" <> T.unpack label, roundTrips (TemplateRecorded (TemplateRecordedData (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))) mappedValue (snd (NonEmpty.head (fixtureCases Bindings.templateBookFixtures))))))
| (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.templateRefFixtures)
]
templateRecordedBookAssertions :: [(String, Bool)]
templateRecordedBookAssertions =
[ ("mapped codec round-trip: TemplateRecorded/book/" <> T.unpack label, roundTrips (TemplateRecorded (TemplateRecordedData (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.templateRefFixtures))) mappedValue)))
| (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.templateBookFixtures)
]
structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
[ ("wire policy missing default: conformance.structural-nominals.TemplateBook.v1/claims", case decodeTemplateBookMapped (deleteObjectField "claims" (encodeTemplateBookMapped (snd (NonEmpty.head (fixtureCases Bindings.templateBookFixtures))))) of Left _ -> False; Right decoded -> objectField "claims" (encodeTemplateBookMapped decoded) == Just (Aeson.Object mempty))
, ("wire policy explicit null: conformance.structural-nominals.TemplateBook.v1/claims", isLeft (decodeTemplateBookMapped (insertObjectField "claims" Aeson.Null (encodeTemplateBookMapped (snd (NonEmpty.head (fixtureCases Bindings.templateBookFixtures)))))))
, ("wire policy unknown fields: conformance.structural-nominals.TemplateBook.v1", all (\(_, value) -> isLeft (decodeTemplateBookMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeTemplateBookMapped value)))) (NonEmpty.toList (fixtureCases Bindings.templateBookFixtures)))
, ("wire union arm: conformance.structural-nominals.TemplateRef.v1/by_id", any (\(_, value) -> objectField "tag" (encodeTemplateRefMapped value) == Just (Aeson.String "by_id") && decodeTemplateRefMapped (encodeTemplateRefMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.templateRefFixtures)))
, ("wire union arm: conformance.structural-nominals.TemplateRef.v1/by_account", any (\(_, value) -> objectField "tag" (encodeTemplateRefMapped value) == Just (Aeson.String "by_account") && decodeTemplateRefMapped (encodeTemplateRefMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.templateRefFixtures)))
, ("wire union arm: conformance.structural-nominals.TemplateRef.v1/by_channel", any (\(_, value) -> objectField "tag" (encodeTemplateRefMapped value) == Just (Aeson.String "by_channel") && decodeTemplateRefMapped (encodeTemplateRefMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.templateRefFixtures)))
, ("wire union arm: conformance.structural-nominals.TemplateRef.v1/unknown", any (\(_, value) -> objectField "tag" (encodeTemplateRefMapped value) == Just (Aeson.String "unknown") && decodeTemplateRefMapped (encodeTemplateRefMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.templateRefFixtures)))
, ("wire policy unknown fields: conformance.structural-nominals.TemplateRef.v1", all (\(_, value) -> isLeft (decodeTemplateRefMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeTemplateRefMapped value)))) (NonEmpty.toList (fixtureCases Bindings.templateRefFixtures)))
, ("wire policy missing default: conformance.structural-nominals.TemplateState.v1/holder", case decodeTemplateStateMapped (deleteObjectField "holder" (encodeTemplateStateMapped (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))))) of Left _ -> False; Right decoded -> objectField "holder" (encodeTemplateStateMapped decoded) == Just (Aeson.Null))
, ("wire policy explicit null: conformance.structural-nominals.TemplateState.v1/holder", isRight (decodeTemplateStateMapped (insertObjectField "holder" Aeson.Null (encodeTemplateStateMapped (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures)))))))
, ("wire policy missing default: conformance.structural-nominals.TemplateState.v1/kind", case decodeTemplateStateMapped (deleteObjectField "kind" (encodeTemplateStateMapped (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))))) of Left _ -> False; Right decoded -> objectField "kind" (encodeTemplateStateMapped decoded) == Just (Aeson.String "draft"))
, ("wire policy explicit null: conformance.structural-nominals.TemplateState.v1/kind", isLeft (decodeTemplateStateMapped (insertObjectField "kind" Aeson.Null (encodeTemplateStateMapped (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures)))))))
, ("wire policy missing default: conformance.structural-nominals.TemplateState.v1/fallbackChannel", case decodeTemplateStateMapped (deleteObjectField "fallbackChannel" (encodeTemplateStateMapped (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures))))) of Left _ -> False; Right decoded -> objectField "fallbackChannel" (encodeTemplateStateMapped decoded) == Just (Aeson.String "email"))
, ("wire policy explicit null: conformance.structural-nominals.TemplateState.v1/fallbackChannel", isLeft (decodeTemplateStateMapped (insertObjectField "fallbackChannel" Aeson.Null (encodeTemplateStateMapped (snd (NonEmpty.head (fixtureCases Bindings.templateStateFixtures)))))))
, ("wire policy unknown fields: conformance.structural-nominals.TemplateState.v1", all (\(_, value) -> isLeft (decodeTemplateStateMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeTemplateStateMapped value)))) (NonEmpty.toList (fixtureCases Bindings.templateStateFixtures)))
]
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: ClaimId", all (\fixture -> nominalDomainRoundTrip Bindings.claimIdBinding (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.claimIdFixtures)))
, ("nominal representation law: ClaimId", all (\fixture -> let domainValue = nominalFixtureDomain fixture in nominalRepresentationRoundTrip Bindings.claimIdBinding (nominalToRepresentation Bindings.claimIdBinding domainValue)) (NonEmpty.toList (nominalFixtureCases Bindings.claimIdFixtures)))
, ("nominal ID projection agreement: ClaimId", all (\fixture -> fieldWitnessAgrees NominalProjections.claimIdEqualityWitness (KindID.toText . nominalToRepresentation Bindings.claimIdBinding) (nominalFixtureDomain fixture)) (NonEmpty.toList (nominalFixtureCases Bindings.claimIdFixtures)))
, ("nominal ID fixture domain agreement: ClaimId", all (\fixture -> case validateIdDomainText (typeIdV7Domain "claim") (KindID.toText (nominalToRepresentation Bindings.claimIdBinding (nominalFixtureDomain fixture))) of Right () -> True; Left _ -> False) (NonEmpty.toList (nominalFixtureCases Bindings.claimIdFixtures)))
, ("nominal ID binding preserves canonical representations: ClaimId", all (nominalRepresentationRoundTrip Bindings.claimIdBinding) [(case KindID.parseText @"claim" "claim_01h455vb4pex5vsknk084sn02q" of Right parsed -> parsed; Left _ -> error "generated canonical ID conformance probe failed to parse"), (case KindID.parseText @"claim" "claim_01h455vb4pex5vsknk084sn02r" of Right parsed -> parsed; Left _ -> error "generated canonical ID conformance probe failed to parse")])
, ("nominal ID boundary rejects wrong-prefix and normalized text: ClaimId", case (validateIdDomainText (typeIdV7Domain "claim") "wrong_01h455vb4pex5vsknk084sn02q", validateIdDomainText (typeIdV7Domain "claim") (T.toUpper "claim_01h455vb4pex5vsknk084sn02q")) of (Left _, Left _) -> True; _ -> False)
]