Harness.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.
module SkelAggregate.Generated.MyService.Thing.Harness (harnessAssertions) where

import SkelAggregate.Generated.MyService.Thing.Domain
import SkelAggregate.Generated.MyService.Thing.Codec (encodeThingEvent, parseThingEvent, thingCodec)
import SkelAggregate.MyService.Thing.Holes (thingTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))
import Keiro.Codec (eventType)
import SkelAggregate.Generated.MyService.Nominals (ThingId (..))

{- | (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 thingTransducer))
  , ("clock-free: spec samples no wall clock", True)
  , ("golden round-trip: ThingCompleted", roundTrips sampleEventThingCompleted)
  , ("accepts DoThing from ThingPending", acceptDoThing)
  ]
  ++ forwardReplayDoThing

roundTrips :: ThingEvent -> Bool
roundTrips e = parseThingEvent (eventType thingCodec e) (encodeThingEvent e) == Right e

sampleEventThingCompleted :: ThingEvent
sampleEventThingCompleted = (ThingCompleted (ThingCompletedData (ThingId "sample") 0))

acceptDoThing :: Bool
acceptDoThing =
  case step thingTransducer (ThingPending, initialThingRegs) ((DoThing (DoThingData (ThingId "sample") 0))) of
    Just (v, _, _) -> v == ThingDone
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayDoThing :: [(String, Bool)]
forwardReplayDoThing =
  case step thingTransducer (ThingPending, initialThingRegs) ((DoThing (DoThingData (ThingId "sample") 0))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, forwardRegs, emitted) ->
      case mapM (\event -> parseThingEvent (eventType thingCodec event) (encodeThingEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither thingTransducer (ThingPending, initialThingRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              , (prefix <> "register thingId", (replayRegs ! #thingId) == (forwardRegs ! #thingId))
              , (prefix <> "register state", (replayRegs ! #state) == (forwardRegs ! #state))
              ]
  where
    prefix = "forward/replay equality: DoThing from ThingPending -- "