Codec.hs

{-# LANGUAGE OverloadedRecordDot #-}
-- @generated by keiro-dsl 0.9.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.
module Generated.HospitalCapacity.Reservation.Codec (
    reservationCodec,
    parseReservationEvent,
    encodeReservationEvent,
) where

import Generated.HospitalCapacity.Reservation.Domain
import Generated.HospitalCapacity.Nominals (CommandId, commandIdText, DivertStatus (..), divertStatusText, HospitalId, hospitalIdText, PatientAcuity (..), patientAcuityText, TransferReservationId, transferReservationIdText)
import Generated.HospitalCapacity.Nominals.Internal (unsafeCommandIdFromLegacyText, unsafeHospitalIdFromLegacyText, unsafeTransferReservationIdFromLegacyText)
import Data.Aeson (Value, object, withObject, withText, (.:), (.=))
import Data.Aeson.Types (Parser, explicitParseField, parseEither)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text (Text)
import qualified Data.Text as T
import Keiro.Codec (Codec (..), EventType (..))
import HospitalCapacity.Reservation.Holes (upcastTransferReservationCreatedV1)

parseDivertStatus :: Text -> Parser DivertStatus
parseDivertStatus = \case
  "open" -> pure Open
  "partial-divert" -> pure PartialDivert
  "total-divert" -> pure TotalDivert
  tag -> fail ("unknown DivertStatus " <> show tag <> "; expected one of: open, partial-divert, total-divert")

parsePatientAcuity :: Text -> Parser PatientAcuity
parsePatientAcuity = \case
  "red" -> pure RedTag
  "yellow" -> pure YellowTag
  "green" -> pure GreenTag
  tag -> fail ("unknown PatientAcuity " <> show tag <> "; expected one of: red, yellow, green")


reservationEventTypes :: NonEmpty EventType
reservationEventTypes = EventType "TransferReservationCreated" :| [EventType "TransferReservationConfirmed"]

reservationCodec :: Codec ReservationEvent
reservationCodec =
  Codec
    { eventTypes = reservationEventTypes
    , eventType = \case
        TransferReservationCreated{} -> EventType "TransferReservationCreated"
        TransferReservationConfirmed{} -> EventType "TransferReservationConfirmed"
    , schemaVersion = 2
    , encode = encodeReservationEvent
    , decode = parseReservationEvent
    , upcasters = [(1, upcastRungV1)]
    }

upcastRungV1 :: EventType -> Value -> Either Text Value
upcastRungV1 (EventType "TransferReservationCreated") value = upcastTransferReservationCreatedV1 value
-- Kinds whose shape did not change at this rung pass through unchanged; their
-- stamped version is aggregate-global, not their own shape history.
upcastRungV1 _ value = Right value

encodeReservationEvent :: ReservationEvent -> Value
encodeReservationEvent = \case
  TransferReservationCreated payload ->
    object
      [ "kind" .= ("TransferReservationCreated" :: Text)
      , "reservationId" .= transferReservationIdText payload.reservationId
      , "hospitalId" .= hospitalIdText payload.hospitalId
      , "commandId" .= commandIdText payload.commandId
      , "patientAcuity" .= patientAcuityText payload.patientAcuity
      , "divertStatus" .= divertStatusText payload.divertStatus
      , "lifeCriticalOverride" .= payload.lifeCriticalOverride
      , "triageNote" .= payload.triageNote
      ]
  TransferReservationConfirmed payload ->
    object
      [ "kind" .= ("TransferReservationConfirmed" :: Text)
      , "reservationId" .= transferReservationIdText payload.reservationId
      , "hospitalId" .= hospitalIdText payload.hospitalId
      , "commandId" .= commandIdText payload.commandId
      ]

parseReservationEvent :: EventType -> Value -> Either Text ReservationEvent
parseReservationEvent (EventType tag) = mapLeftText . parseEither (withObject "ReservationEvent" go)
  where
    go o = do
      case tag of
        "TransferReservationCreated" ->
          TransferReservationCreated
            <$> ( TransferReservationCreatedData
                    <$> (unsafeTransferReservationIdFromLegacyText <$> o .: "reservationId")
                    <*> (unsafeHospitalIdFromLegacyText <$> o .: "hospitalId")
                    <*> (unsafeCommandIdFromLegacyText <$> o .: "commandId")
                    <*> explicitParseField (withText "PatientAcuity" parsePatientAcuity) o "patientAcuity"
                    <*> explicitParseField (withText "DivertStatus" parseDivertStatus) o "divertStatus"
                    <*> o .: "lifeCriticalOverride"
                    <*> o .: "triageNote"
                )
        "TransferReservationConfirmed" ->
          TransferReservationConfirmed
            <$> ( TransferReservationConfirmedData
                    <$> (unsafeTransferReservationIdFromLegacyText <$> o .: "reservationId")
                    <*> (unsafeHospitalIdFromLegacyText <$> o .: "hospitalId")
                    <*> (unsafeCommandIdFromLegacyText <$> o .: "commandId")
                )
        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> _renderEventTypes reservationEventTypes)

mapLeftText :: Either String b -> Either Text b
mapLeftText = either (Left . T.pack) Right

_renderEventTypes :: NonEmpty EventType -> String
_renderEventTypes =
  T.unpack
    . T.intercalate ", "
    . map (\(EventType eventTypeName) -> eventTypeName)
    . NonEmpty.toList