Harness.hs

{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl 0.18.0.0 (language keiro-dsl 6) from aggregate LabelStore; do not edit.
module Generated.StructuralTextSets.LabelStore.Harness (harnessAssertions) where

import Generated.StructuralTextSets.LabelStore.Domain
import Generated.StructuralTextSets.LabelStore.Codec (encodeLabelStoreEvent, parseLabelStoreEvent, labelStoreCodec, encodeLabelEnvelopeMapped, decodeLabelEnvelopeMapped)
import Generated.StructuralTextSets.LabelStore.Transducer (labelStoreTransducer)
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.StructuralTextSets.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 labelStoreTransducer))
  -- clock-free: spec samples no wall clock (verified at scaffold time)
  , ("golden round-trip: LabelsStored", roundTrips sampleEventLabelsStored)
  , ("golden round-trip: LabelsAudited", roundTrips sampleEventLabelsAudited)
  , ("golden round-trip: LegacyLabelsImported", roundTrips sampleEventLegacyLabelsImported)
  , ("accepts StoreLabels from LabelStoreEmpty", acceptStoreLabels)
  ]
  ++ mappedConformanceAssertions
  ++ forwardReplayStoreLabels

roundTrips :: LabelStoreEvent -> Bool
roundTrips e = parseLabelStoreEvent (eventType labelStoreCodec e) (encodeLabelStoreEvent e) == Right e

sampleEventLabelsStored :: LabelStoreEvent
sampleEventLabelsStored = LabelsStored (LabelsStoredData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))

sampleEventLabelsAudited :: LabelStoreEvent
sampleEventLabelsAudited = LabelsAudited (LabelsAuditedData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))

sampleEventLegacyLabelsImported :: LabelStoreEvent
sampleEventLegacyLabelsImported = LegacyLabelsImported (LegacyLabelsImportedData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))

acceptStoreLabels :: Bool
acceptStoreLabels =
  case step labelStoreTransducer (LabelStoreEmpty, initialLabelStoreRegs) (StoreLabels (StoreLabelsData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))) of
    Just (v, _, _) -> v == LabelStoreStored
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayStoreLabels :: [(String, Bool)]
forwardReplayStoreLabels =
  case step labelStoreTransducer (LabelStoreEmpty, initialLabelStoreRegs) (StoreLabels (StoreLabelsData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, forwardRegs, emitted) ->
      case mapM (\event -> parseLabelStoreEvent (eventType labelStoreCodec event) (encodeLabelStoreEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither labelStoreTransducer (LabelStoreEmpty, initialLabelStoreRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              , (prefix <> "register current", (replayRegs ! #current) == (forwardRegs ! #current))
              ]
  where
    prefix = "forward/replay equality: StoreLabels from LabelStoreEmpty -- "

mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
  concat
    [ labelsStoredLabelsAssertions
    , labelsStoredOptionalLabelsAssertions
    , labelsStoredEnvelopeAssertions
    , labelsAuditedLabelsAssertions
    , labelsAuditedOptionalLabelsAssertions
    , labelsAuditedEnvelopeAssertions
    , legacyLabelsImportedLabelsAssertions
    , legacyLabelsImportedOptionalLabelsAssertions
    , legacyLabelsImportedEnvelopeAssertions
    , structuralWirePolicyAssertions
    ]

labelsStoredLabelsAssertions :: [(String, Bool)]
labelsStoredLabelsAssertions =
  [ ("mapped codec round-trip: LabelsStored/labels/" <> T.unpack label, roundTrips (LabelsStored (LabelsStoredData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.textLabelsFixtures)
  ]

labelsStoredOptionalLabelsAssertions :: [(String, Bool)]
labelsStoredOptionalLabelsAssertions =
  [ ("mapped codec round-trip: LabelsStored/optionalLabels/" <> T.unpack label, roundTrips (LabelsStored (LabelsStoredData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) mappedValue (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.maybeTextLabelsFixtures)
  ]

labelsStoredEnvelopeAssertions :: [(String, Bool)]
labelsStoredEnvelopeAssertions =
  [ ("mapped codec round-trip: LabelsStored/envelope/" <> T.unpack label, roundTrips (LabelsStored (LabelsStoredData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.labelEnvelopeFixtures)
  ]

labelsAuditedLabelsAssertions :: [(String, Bool)]
labelsAuditedLabelsAssertions =
  [ ("mapped codec round-trip: LabelsAudited/labels/" <> T.unpack label, roundTrips (LabelsAudited (LabelsAuditedData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.textLabelsFixtures)
  ]

labelsAuditedOptionalLabelsAssertions :: [(String, Bool)]
labelsAuditedOptionalLabelsAssertions =
  [ ("mapped codec round-trip: LabelsAudited/optionalLabels/" <> T.unpack label, roundTrips (LabelsAudited (LabelsAuditedData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) mappedValue (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.maybeTextLabelsFixtures)
  ]

labelsAuditedEnvelopeAssertions :: [(String, Bool)]
labelsAuditedEnvelopeAssertions =
  [ ("mapped codec round-trip: LabelsAudited/envelope/" <> T.unpack label, roundTrips (LabelsAudited (LabelsAuditedData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.labelEnvelopeFixtures)
  ]

legacyLabelsImportedLabelsAssertions :: [(String, Bool)]
legacyLabelsImportedLabelsAssertions =
  [ ("mapped codec round-trip: LegacyLabelsImported/labels/" <> T.unpack label, roundTrips (LegacyLabelsImported (LegacyLabelsImportedData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.textLabelsFixtures)
  ]

legacyLabelsImportedOptionalLabelsAssertions :: [(String, Bool)]
legacyLabelsImportedOptionalLabelsAssertions =
  [ ("mapped codec round-trip: LegacyLabelsImported/optionalLabels/" <> T.unpack label, roundTrips (LegacyLabelsImported (LegacyLabelsImportedData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) mappedValue (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.maybeTextLabelsFixtures)
  ]

legacyLabelsImportedEnvelopeAssertions :: [(String, Bool)]
legacyLabelsImportedEnvelopeAssertions =
  [ ("mapped codec round-trip: LegacyLabelsImported/envelope/" <> T.unpack label, roundTrips (LegacyLabelsImported (LegacyLabelsImportedData (snd (NonEmpty.head (fixtureCases Bindings.textLabelsFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeTextLabelsFixtures))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.labelEnvelopeFixtures)
  ]

structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
  [ ("wire policy missing default: conformance.structural-text-sets.LabelEnvelope.v1/optionalLabels", case decodeLabelEnvelopeMapped (deleteObjectField "optionalLabels" (encodeLabelEnvelopeMapped (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures))))) of Left _ -> False; Right decoded -> objectField "optionalLabels" (encodeLabelEnvelopeMapped decoded) == Just (Aeson.Null))
  , ("wire policy explicit null: conformance.structural-text-sets.LabelEnvelope.v1/optionalLabels", isRight (decodeLabelEnvelopeMapped (insertObjectField "optionalLabels" Aeson.Null (encodeLabelEnvelopeMapped (snd (NonEmpty.head (fixtureCases Bindings.labelEnvelopeFixtures)))))))
  , ("wire policy unknown fields: conformance.structural-text-sets.LabelEnvelope.v1", all (\(_, value) -> isLeft (decodeLabelEnvelopeMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeLabelEnvelopeMapped value)))) (NonEmpty.toList (fixtureCases Bindings.labelEnvelopeFixtures)))
  ]

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