keiro-dsl-0.10.0.0: test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs
{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl 0.9.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, 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 Generated.StructuralConformance.StructuralProjections qualified as StructuralProjections
import Conformance.Structural.Bindings qualified as Bindings
import Conformance.Structural.Domain (ArtifactInfo, ArtifactKind, ArtifactLocation, ArtifactMetadata, Geometry)
import Generated.StructuralConformance.Structural.Shape.ArtifactInfo qualified as ShapeArtifactInfo
import Generated.StructuralConformance.Structural.Shape.ArtifactKind qualified as ShapeArtifactKind
import Generated.StructuralConformance.Structural.Shape.ArtifactLocation qualified as ShapeArtifactLocation
import Generated.StructuralConformance.Structural.Shape.ArtifactMetadata qualified as ShapeArtifactMetadata
-- | (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", True)
, ("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
[ artifactInfoBindingAssertions
, artifactKindBindingAssertions
, artifactLocationBindingAssertions
, artifactMetadataBindingAssertions
, vendorGeometryOpaqueAssertions
, [("fixture coverage: conformance.structural.ArtifactInfo.v1", coverageArtifactInfo)]
, [("fixture coverage: conformance.structural.ArtifactKind.v1", coverageArtifactKind)]
, [("fixture coverage: conformance.structural.ArtifactLocation.v1", coverageArtifactLocation)]
, [("fixture coverage: conformance.structural.ArtifactMetadata.v1", coverageArtifactMetadata)]
, artifactRecordedArtifactAssertions
, artifactRecordedGeometryAssertions
, 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)
artifactInfoBindingAssertions :: [(String, Bool)]
artifactInfoBindingAssertions =
("fixture labels: conformance.structural.ArtifactInfo.v1", validFixtureLabels cases) :
("canonical identity: conformance.structural.ArtifactInfo.v1", canonicalTypeName (Proxy @ArtifactInfo) == "conformance.structural.ArtifactInfo.v1") :
concat
[ [ ("binding domain round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactInfoBinding value)
, ("binding shape round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactInfoBinding (bindingToShape Bindings.artifactInfoBinding value))
]
| (label, value) <- NonEmpty.toList cases
]
where
cases = fixtureCases Bindings.artifactInfoCases
artifactKindBindingAssertions :: [(String, Bool)]
artifactKindBindingAssertions =
("fixture labels: conformance.structural.ArtifactKind.v1", validFixtureLabels cases) :
("canonical identity: conformance.structural.ArtifactKind.v1", canonicalTypeName (Proxy @ArtifactKind) == "conformance.structural.ArtifactKind.v1") :
concat
[ [ ("binding domain round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactKindBinding value)
, ("binding shape round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactKindBinding (bindingToShape Bindings.artifactKindBinding value))
]
| (label, value) <- NonEmpty.toList cases
]
where
cases = fixtureCases Bindings.artifactKindCases
artifactLocationBindingAssertions :: [(String, Bool)]
artifactLocationBindingAssertions =
("fixture labels: conformance.structural.ArtifactLocation.v1", validFixtureLabels cases) :
("canonical identity: conformance.structural.ArtifactLocation.v1", canonicalTypeName (Proxy @ArtifactLocation) == "conformance.structural.ArtifactLocation.v1") :
concat
[ [ ("binding domain round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactLocationBinding value)
, ("binding shape round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactLocationBinding (bindingToShape Bindings.artifactLocationBinding value))
]
| (label, value) <- NonEmpty.toList cases
]
where
cases = fixtureCases Bindings.artifactLocationCases
artifactMetadataBindingAssertions :: [(String, Bool)]
artifactMetadataBindingAssertions =
("fixture labels: conformance.structural.ArtifactMetadata.v1", validFixtureLabels cases) :
("canonical identity: conformance.structural.ArtifactMetadata.v1", canonicalTypeName (Proxy @ArtifactMetadata) == "conformance.structural.ArtifactMetadata.v1") :
concat
[ [ ("binding domain round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactMetadataBinding value)
, ("binding shape round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactMetadataBinding (bindingToShape Bindings.artifactMetadataBinding value))
]
| (label, value) <- NonEmpty.toList cases
]
where
cases = fixtureCases Bindings.artifactMetadataCases
vendorGeometryOpaqueAssertions :: [(String, Bool)]
vendorGeometryOpaqueAssertions =
("opaque boundary fixtures: vendor.geometry.json@3", validFixtureLabels cases) :
[ ("opaque codec round-trip: vendor.geometry.json@3/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)
| (caseLabel, value) <- NonEmpty.toList cases
]
where
cases = fixtureCases Bindings.geometryCases
coverageArtifactInfo :: Bool
coverageArtifactInfo = any (isNothing . ShapeArtifactInfo.artifactHash) shapes && any (isJust . ShapeArtifactInfo.artifactHash) shapes
where
shapes = map (bindingToShape Bindings.artifactInfoBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases))
coverageArtifactKind :: Bool
coverageArtifactKind = any (\case ShapeArtifactKind.Guide -> True; _ -> False) shapes && any (\case ShapeArtifactKind.Reference -> True; _ -> False) shapes
where
shapes = map (bindingToShape Bindings.artifactKindBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactKindCases))
coverageArtifactLocation :: Bool
coverageArtifactLocation = any (\case ShapeArtifactLocation.LocalFile{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.LocalDir{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.RepoPath{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.LocUrl{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.Canonical -> True; _ -> False) shapes
where
shapes = map (bindingToShape Bindings.artifactLocationBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases))
coverageArtifactMetadata :: Bool
coverageArtifactMetadata = any (isNothing . ShapeArtifactMetadata.note) shapes && any (isJust . ShapeArtifactMetadata.note) shapes
where
shapes = map (bindingToShape Bindings.artifactMetadataBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactMetadataCases))
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)))
]
structuralProjectionAssertions :: [(String, Bool)]
structuralProjectionAssertions =
[ ("projection witness agreement: conformance.structural.ArtifactInfo.v1/artifact_key", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.artifactInfoArtifactKeyWitness (\referenceOwner -> ShapeArtifactInfo.artifactKey (bindingToShape Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)))
, ("projection witness agreement: conformance.structural.ArtifactInfo.v1/display_name", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.artifactInfoDisplayNameWitness (\referenceOwner -> ShapeArtifactInfo.displayName (bindingToShape Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)))
]
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