Codec.hs

-- @generated by keiro-dsl 0.18.0.0 (language keiro-dsl 6) from aggregate CalendarStore; do not edit.
module Generated.CalendarDays.CalendarStore.Codec (
    calendarStoreCodec,
    parseCalendarStoreEvent,
    encodeCalendarStoreEvent,
    encodeCalendarEnvelopeMapped,
    decodeCalendarEnvelopeMapped,
    encodeLocalDayMapped,
    decodeLocalDayMapped,
    encodeMaybeLocalDayMapped,
    decodeMaybeLocalDayMapped,
) where

import Generated.CalendarDays.CalendarStore.Domain
import Control.Monad (unless)
import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, (.=))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (Parser, JSONPathElement (..), (<?>), explicitParseField, parseEither)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import qualified Data.Text as T
import Keiro.Codec.CalendarDay (encodeCalendarDay, parseCalendarDay)
import Keiro.Codec.Structural (bindingFromShape, bindingToShape)
import Keiro.Codec (Codec (..), EventType (..))


import Conformance.CalendarDays.Bindings qualified as Bindings
import Conformance.CalendarDays.Domain (CalendarEnvelope, LocalDay, MaybeLocalDay)
import Generated.CalendarDays.Structural.Shape.CalendarEnvelope qualified as ShapeCalendarEnvelope
import Generated.CalendarDays.Structural.Shape.LocalDay qualified as ShapeLocalDay
import Generated.CalendarDays.Structural.Shape.MaybeLocalDay qualified as ShapeMaybeLocalDay



encodeCalendarEnvelopeMapped :: CalendarEnvelope -> Value
encodeCalendarEnvelopeMapped = encodeCalendarEnvelopeShape . bindingToShape Bindings.calendarEnvelopeBinding

parseCalendarEnvelopeMapped :: Value -> Parser CalendarEnvelope
parseCalendarEnvelopeMapped value = bindingFromShape Bindings.calendarEnvelopeBinding <$> parseCalendarEnvelopeShape value

decodeCalendarEnvelopeMapped :: Value -> Either Text CalendarEnvelope
decodeCalendarEnvelopeMapped = mapLeftText . parseEither parseCalendarEnvelopeMapped

encodeCalendarEnvelopeShape :: ShapeCalendarEnvelope.CalendarEnvelopeShape -> Value
encodeCalendarEnvelopeShape shape =
  object
      [ "primary" .= encodeCalendarDay (shape.primary)
      , "optionalDay" .= maybe Null (\item0 -> encodeCalendarDay (item0)) (shape.optionalDay)
      , "namedOptional" .= encodeMaybeLocalDayShape (shape.namedOptional)
      , "sequence" .= toJSON (map (\item0 -> encodeCalendarDay (item0)) (shape.sequence))
      , "labelled" .= toJSON (Map.map (\item0 -> encodeCalendarDay (item0)) (shape.labelled))
      ]

parseCalendarEnvelopeShape :: Value -> Parser ShapeCalendarEnvelope.CalendarEnvelopeShape
parseCalendarEnvelopeShape = withObject "CalendarEnvelopeShape" $ \objectValue -> do
  rejectUnknownFields "CalendarEnvelope" ["primary", "optionalDay", "namedOptional", "sequence", "labelled"] objectValue
  ShapeCalendarEnvelope.CalendarEnvelope
    <$> explicitParseField (parseCalendarDay) objectValue "primary"
    <*> parseOptionalField (pure Nothing) (\value0 -> case value0 of Null -> pure Nothing; other0 -> Just <$> (parseCalendarDay) other0) objectValue "optionalDay"
    <*> explicitParseField (parseMaybeLocalDayShape) objectValue "namedOptional"
    <*> explicitParseField (\value0 -> do items0 <- (parseJSON value0 :: Parser [Value]); traverse (\(index0, item0) -> (parseCalendarDay) item0 <?> Index index0) (zip [0..] items0)) objectValue "sequence"
    <*> explicitParseField (\value0 -> do items0 <- (parseJSON value0 :: Parser (Map Text Value)); Map.traverseWithKey (\key0 item0 -> (parseCalendarDay) item0 <?> Key (Key.fromText key0)) items0) objectValue "labelled"

encodeLocalDayMapped :: LocalDay -> Value
encodeLocalDayMapped = encodeLocalDayShape . bindingToShape Bindings.localDayBinding

parseLocalDayMapped :: Value -> Parser LocalDay
parseLocalDayMapped value = bindingFromShape Bindings.localDayBinding <$> parseLocalDayShape value

decodeLocalDayMapped :: Value -> Either Text LocalDay
decodeLocalDayMapped = mapLeftText . parseEither parseLocalDayMapped

encodeLocalDayShape :: ShapeLocalDay.LocalDayShape -> Value
encodeLocalDayShape value = encodeCalendarDay (value)

parseLocalDayShape :: Value -> Parser ShapeLocalDay.LocalDayShape
parseLocalDayShape = parseCalendarDay

encodeMaybeLocalDayMapped :: MaybeLocalDay -> Value
encodeMaybeLocalDayMapped = encodeMaybeLocalDayShape . bindingToShape Bindings.maybeLocalDayBinding

parseMaybeLocalDayMapped :: Value -> Parser MaybeLocalDay
parseMaybeLocalDayMapped value = bindingFromShape Bindings.maybeLocalDayBinding <$> parseMaybeLocalDayShape value

decodeMaybeLocalDayMapped :: Value -> Either Text MaybeLocalDay
decodeMaybeLocalDayMapped = mapLeftText . parseEither parseMaybeLocalDayMapped

encodeMaybeLocalDayShape :: ShapeMaybeLocalDay.MaybeLocalDayShape -> Value
encodeMaybeLocalDayShape value = maybe Null (\item0 -> encodeCalendarDay (item0)) (value)

parseMaybeLocalDayShape :: Value -> Parser ShapeMaybeLocalDay.MaybeLocalDayShape
parseMaybeLocalDayShape = \value0 -> case value0 of Null -> pure Nothing; other0 -> Just <$> (parseCalendarDay) other0

calendarStoreEventTypes :: NonEmpty EventType
calendarStoreEventTypes = EventType "DateStored" :| [EventType "DateAudited"]

calendarStoreCodec :: Codec CalendarStoreEvent
calendarStoreCodec =
  Codec
    { eventTypes = calendarStoreEventTypes
    , eventType = \case
        DateStored{} -> EventType "DateStored"
        DateAudited{} -> EventType "DateAudited"
    , schemaVersion = 1
    , encode = encodeCalendarStoreEvent
    , decode = parseCalendarStoreEvent
    , upcasters = []
    }

encodeCalendarStoreEvent :: CalendarStoreEvent -> Value
encodeCalendarStoreEvent = \case
  DateStored payload ->
    object
      [ "kind" .= ("DateStored" :: Text)
      , "day" .= encodeLocalDayMapped payload.day
      , "optionalDay" .= encodeMaybeLocalDayMapped payload.optionalDay
      , "envelope" .= encodeCalendarEnvelopeMapped payload.envelope
      ]
  DateAudited payload ->
    object
      [ "kind" .= ("DateAudited" :: Text)
      , "day" .= encodeLocalDayMapped payload.day
      , "optionalDay" .= encodeMaybeLocalDayMapped payload.optionalDay
      , "envelope" .= encodeCalendarEnvelopeMapped payload.envelope
      ]

parseCalendarStoreEvent :: EventType -> Value -> Either Text CalendarStoreEvent
parseCalendarStoreEvent (EventType tag) = mapLeftText . parseEither (withObject "CalendarStoreEvent" go)
  where
    go o = do
      case tag of
        "DateStored" ->
          DateStored
            <$> ( DateStoredData
                    <$> explicitParseField parseLocalDayMapped o "day"
                    <*> parseOptionalField (parseMaybeLocalDayMapped Null) parseMaybeLocalDayMapped o "optionalDay"
                    <*> explicitParseField parseCalendarEnvelopeMapped o "envelope"
                )
        "DateAudited" ->
          DateAudited
            <$> ( DateAuditedData
                    <$> explicitParseField parseLocalDayMapped o "day"
                    <*> parseOptionalField (parseMaybeLocalDayMapped Null) parseMaybeLocalDayMapped o "optionalDay"
                    <*> explicitParseField parseCalendarEnvelopeMapped o "envelope"
                )
        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes calendarStoreEventTypes)

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

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

parseOptionalField :: Parser fieldValue -> (Value -> Parser fieldValue) -> KeyMap.KeyMap Value -> Key.Key -> Parser fieldValue
parseOptionalField onMissing parseItem objectValue key =
  case KeyMap.lookup key objectValue of
    Nothing -> onMissing
    Just _ -> explicitParseField parseItem objectValue key

rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()
rejectUnknownFields label allowed objectValue =
  unless (null extras) (fail (label <> " contains unknown fields: " <> show extras))
  where
    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))