Harness.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}

-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.
module Generated.HospitalCapacity.Reservation.Harness (harnessAssertions) where

import Generated.HospitalCapacity.Reservation.Codec (encodeReservationEvent, parseReservationEvent, reservationCodec)
import Generated.HospitalCapacity.Reservation.Domain
import HospitalCapacity.Reservation.Holes (reservationTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))
import Keiro.Codec (eventType)

{- | (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 reservationTransducer))
    , ("clock-free: spec samples no wall clock", True)
    , ("golden round-trip: TransferReservationCreated", roundTrips sampleEventTransferReservationCreated)
    , ("golden round-trip: TransferReservationConfirmed", roundTrips sampleEventTransferReservationConfirmed)
    , ("accepts RequestTransferReservation from ReservationUnrequested", acceptRequestTransferReservation)
    ]
        ++ forwardReplayRequestTransferReservation

roundTrips :: ReservationEvent -> Bool
roundTrips e = parseReservationEvent (eventType reservationCodec e) (encodeReservationEvent e) == Right e

sampleEventTransferReservationCreated :: ReservationEvent
sampleEventTransferReservationCreated = (TransferReservationCreated (TransferReservationCreatedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))

sampleEventTransferReservationConfirmed :: ReservationEvent
sampleEventTransferReservationConfirmed = (TransferReservationConfirmed (TransferReservationConfirmedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample")))

acceptRequestTransferReservation :: Bool
acceptRequestTransferReservation =
    case step reservationTransducer (ReservationUnrequested, initialReservationRegs) ((RequestTransferReservation (RequestTransferReservationData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))) of
        Just (v, _, _) -> v == ReservationHeld
        Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayRequestTransferReservation :: [(String, Bool)]
forwardReplayRequestTransferReservation =
    case step reservationTransducer (ReservationUnrequested, initialReservationRegs) ((RequestTransferReservation (RequestTransferReservationData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))) of
        Nothing -> [(prefix <> "forward step accepted", False)]
        Just (forwardVertex, forwardRegs, emitted) ->
            case mapM (\event -> parseReservationEvent (eventType reservationCodec event) (encodeReservationEvent event)) emitted of
                Left _ -> [(prefix <> "emitted chain decodes", False)]
                Right decodedEvents ->
                    case applyEventsEither reservationTransducer (ReservationUnrequested, initialReservationRegs) decodedEvents of
                        Left _ -> [(prefix <> "replay succeeds", False)]
                        Right (replayVertex, replayRegs) ->
                            [ (prefix <> "final vertex", replayVertex == forwardVertex)
                            , (prefix <> "register reservationId", (replayRegs ! #reservationId) == (forwardRegs ! #reservationId))
                            , (prefix <> "register hospitalId", (replayRegs ! #hospitalId) == (forwardRegs ! #hospitalId))
                            , (prefix <> "register patientAcuity", (replayRegs ! #patientAcuity) == (forwardRegs ! #patientAcuity))
                            , (prefix <> "register reservationState", (replayRegs ! #reservationState) == (forwardRegs ! #reservationState))
                            ]
  where
    prefix = "forward/replay equality: RequestTransferReservation from ReservationUnrequested -- "