keiro-dsl-0.12.0.0: test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs
{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.
module Generated.StructuralConformance.ArtifactCatalog.Harness (harnessAssertions) where
import Generated.StructuralConformance.ArtifactCatalog.Domain
import Generated.StructuralConformance.ArtifactCatalog.Codec (encodeArtifactCatalogEvent, parseArtifactCatalogEvent, artifactCatalogCodec, encodeArtifactInfoMapped, decodeArtifactInfoMapped, encodeArtifactKindMapped, decodeArtifactKindMapped, encodeArtifactLocationMapped, decodeArtifactLocationMapped, encodeArtifactMetadataMapped, decodeArtifactMetadataMapped)
import Generated.StructuralConformance.ArtifactCatalog.Transducer (artifactCatalogTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))
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.NonEmpty qualified as NonEmpty
import Data.Text qualified as T
import Keiro.Codec.Structural (FixtureCases (..))
import Conformance.Structural.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 artifactCatalogTransducer))
-- clock-free: spec samples no wall clock (verified at scaffold time)
, ("golden round-trip: ArtifactRecorded", roundTrips sampleEventArtifactRecorded)
, ("golden round-trip: ArtifactAccepted", roundTrips sampleEventArtifactAccepted)
, ("accepts ObserveArtifact from ArtifactCatalogEmpty", acceptObserveArtifact)
]
++ mappedConformanceAssertions
++ forwardReplayObserveArtifact
roundTrips :: ArtifactCatalogEvent -> Bool
roundTrips e = parseArtifactCatalogEvent (eventType artifactCatalogCodec e) (encodeArtifactCatalogEvent e) == Right e
sampleEventArtifactRecorded :: ArtifactCatalogEvent
sampleEventArtifactRecorded = ArtifactRecorded (ArtifactRecordedData (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))) (snd (NonEmpty.head (fixtureCases Bindings.geometryCases))) False)
sampleEventArtifactAccepted :: ArtifactCatalogEvent
sampleEventArtifactAccepted = ArtifactAccepted (ArtifactAcceptedData False)
acceptObserveArtifact :: Bool
acceptObserveArtifact =
case step artifactCatalogTransducer (ArtifactCatalogEmpty, initialArtifactCatalogRegs) (ObserveArtifact (ObserveArtifactData (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))) (snd (NonEmpty.head (fixtureCases Bindings.geometryCases))) False)) of
Just (v, _, _) -> v == ArtifactCatalogObserved
Nothing -> False
-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayObserveArtifact :: [(String, Bool)]
forwardReplayObserveArtifact =
case step artifactCatalogTransducer (ArtifactCatalogEmpty, initialArtifactCatalogRegs) (ObserveArtifact (ObserveArtifactData (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))) (snd (NonEmpty.head (fixtureCases Bindings.geometryCases))) False)) of
Nothing -> [(prefix <> "forward step accepted", False)]
Just (forwardVertex, forwardRegs, emitted) ->
case mapM (\event -> parseArtifactCatalogEvent (eventType artifactCatalogCodec event) (encodeArtifactCatalogEvent event)) emitted of
Left _ -> [(prefix <> "emitted chain decodes", False)]
Right decodedEvents ->
case applyEventsEither artifactCatalogTransducer (ArtifactCatalogEmpty, initialArtifactCatalogRegs) decodedEvents of
Left _ -> [(prefix <> "replay succeeds", False)]
Right (replayVertex, replayRegs) ->
[ (prefix <> "final vertex", replayVertex == forwardVertex)
, (prefix <> "register currentArtifact", (replayRegs ! #currentArtifact) == (forwardRegs ! #currentArtifact))
, (prefix <> "register currentGeometry", (replayRegs ! #currentGeometry) == (forwardRegs ! #currentGeometry))
, (prefix <> "register acceptedCount", (replayRegs ! #acceptedCount) == (forwardRegs ! #acceptedCount))
]
where
prefix = "forward/replay equality: ObserveArtifact from ArtifactCatalogEmpty -- "
mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
concat
[ artifactRecordedArtifactAssertions
, artifactRecordedGeometryAssertions
, structuralWirePolicyAssertions
]
artifactRecordedArtifactAssertions :: [(String, Bool)]
artifactRecordedArtifactAssertions =
[ ("mapped codec round-trip: ArtifactRecorded/artifact/" <> T.unpack label, roundTrips (ArtifactRecorded (ArtifactRecordedData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.geometryCases))) False)))
| (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)
]
artifactRecordedGeometryAssertions :: [(String, Bool)]
artifactRecordedGeometryAssertions =
[ ("mapped codec round-trip: ArtifactRecorded/geometry/" <> T.unpack label, roundTrips (ArtifactRecorded (ArtifactRecordedData (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))) mappedValue False)))
| (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.geometryCases)
]
structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
[ ("wire policy missing default: conformance.structural.ArtifactInfo.v1/artifact_hash", case decodeArtifactInfoMapped (deleteObjectField "artifact_hash" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "artifact_hash" (encodeArtifactInfoMapped decoded) == Just (Aeson.Null))
, ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/artifact_hash", isRight (decodeArtifactInfoMapped (insertObjectField "artifact_hash" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases)))))))
, ("wire policy missing default: conformance.structural.ArtifactInfo.v1/artifact_kind", case decodeArtifactInfoMapped (deleteObjectField "artifact_kind" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "artifact_kind" (encodeArtifactInfoMapped decoded) == Just (Aeson.String "guide"))
, ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/artifact_kind", isLeft (decodeArtifactInfoMapped (insertObjectField "artifact_kind" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases)))))))
, ("wire policy missing default: conformance.structural.ArtifactInfo.v1/active", case decodeArtifactInfoMapped (deleteObjectField "active" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "active" (encodeArtifactInfoMapped decoded) == Just (Aeson.Bool False))
, ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/active", isLeft (decodeArtifactInfoMapped (insertObjectField "active" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases)))))))
, ("wire policy missing default: conformance.structural.ArtifactInfo.v1/tags", case decodeArtifactInfoMapped (deleteObjectField "tags" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "tags" (encodeArtifactInfoMapped decoded) == Just (Aeson.toJSON ([] :: [Aeson.Value])))
, ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/tags", isLeft (decodeArtifactInfoMapped (insertObjectField "tags" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases)))))))
, ("wire policy unknown fields: conformance.structural.ArtifactInfo.v1", all (\(_, value) -> isLeft (decodeArtifactInfoMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactInfoMapped value)))) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)))
, ("wire enum arm: conformance.structural.ArtifactKind.v1/guide", any (\(_, value) -> encodeArtifactKindMapped value == Aeson.String "guide" && decodeArtifactKindMapped (Aeson.String "guide") == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactKindCases)))
, ("wire enum arm: conformance.structural.ArtifactKind.v1/reference", any (\(_, value) -> encodeArtifactKindMapped value == Aeson.String "reference" && decodeArtifactKindMapped (Aeson.String "reference") == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactKindCases)))
, ("wire enum unknown tag: conformance.structural.ArtifactKind.v1", isLeft (decodeArtifactKindMapped (Aeson.String "__keiro_unknown")))
, ("wire union arm: conformance.structural.ArtifactLocation.v1/local_file", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "local_file") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))
, ("wire union arm: conformance.structural.ArtifactLocation.v1/local_dir", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "local_dir") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))
, ("wire union arm: conformance.structural.ArtifactLocation.v1/repo_path", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "repo_path") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))
, ("wire union arm: conformance.structural.ArtifactLocation.v1/url", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "url") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))
, ("wire union arm: conformance.structural.ArtifactLocation.v1/canonical", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "canonical") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))
, ("wire policy unknown fields: conformance.structural.ArtifactLocation.v1", all (\(_, value) -> isLeft (decodeArtifactLocationMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactLocationMapped value)))) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))
, ("wire policy unknown fields: conformance.structural.ArtifactMetadata.v1", all (\(_, value) -> isRight (decodeArtifactMetadataMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactMetadataMapped value)))) (NonEmpty.toList (fixtureCases Bindings.artifactMetadataCases)))
]
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