Harness.hs

{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.
module Generated.CatalogDemo.Orders.Harness (harnessAssertions) where

import Generated.CatalogDemo.Orders.Domain
import Generated.CatalogDemo.Orders.Codec (encodeOrdersEvent, parseOrdersEvent, ordersCodec)
import Generated.CatalogDemo.Orders.Transducer (ordersTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))
import Keiro.Codec (eventType)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as T
import Keiro.Codec.Structural (FixtureCases (..))
import CatalogDemo.MappedBindings qualified as MappedBindings

-- | (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 ordersTransducer))
  -- clock-free: spec samples no wall clock (verified at scaffold time)
  , ("golden round-trip: OrderRecorded", roundTrips sampleEventOrderRecorded)
  , ("accepts RecordOrder from OrdersEmpty", acceptRecordOrder)
  ]
  ++ mappedConformanceAssertions
  ++ forwardReplayRecordOrder

roundTrips :: OrdersEvent -> Bool
roundTrips e = parseOrdersEvent (eventType ordersCodec e) (encodeOrdersEvent e) == Right e

sampleEventOrderRecorded :: OrdersEvent
sampleEventOrderRecorded = OrderRecorded (OrderRecordedData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))

acceptRecordOrder :: Bool
acceptRecordOrder =
  case step ordersTransducer (OrdersEmpty, initialOrdersRegs) (RecordOrder (RecordOrderData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))) of
    Just (v, _, _) -> v == OrdersRecorded
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayRecordOrder :: [(String, Bool)]
forwardReplayRecordOrder =
  case step ordersTransducer (OrdersEmpty, initialOrdersRegs) (RecordOrder (RecordOrderData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, forwardRegs, emitted) ->
      case mapM (\event -> parseOrdersEvent (eventType ordersCodec event) (encodeOrdersEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither ordersTransducer (OrdersEmpty, initialOrdersRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              , (prefix <> "register total", (replayRegs ! #total) == (forwardRegs ! #total))
              , (prefix <> "register qualificationState", (replayRegs ! #qualificationState) == (forwardRegs ! #qualificationState))
              ]
  where
    prefix = "forward/replay equality: RecordOrder from OrdersEmpty -- "

mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
  concat
    [ orderRecordedOrderPayloadAssertions
    , orderRecordedSharedReferenceAssertions
    ]

orderRecordedOrderPayloadAssertions :: [(String, Bool)]
orderRecordedOrderPayloadAssertions =
  [ ("mapped codec round-trip: OrderRecorded/orderPayload/" <> T.unpack label, roundTrips (OrderRecorded (OrderRecordedData 0 mappedValue (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases MappedBindings.orderPayloadCases)
  ]

orderRecordedSharedReferenceAssertions :: [(String, Bool)]
orderRecordedSharedReferenceAssertions =
  [ ("mapped codec round-trip: OrderRecorded/sharedReference/" <> T.unpack label, roundTrips (OrderRecorded (OrderRecordedData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases MappedBindings.sharedReferenceCases)
  ]