Main.hs

module Main (main) where

import Conformance.CalendarDays.Bindings (localDayFixtures)
import Conformance.CalendarDays.Domain
import Conformance.CalendarDays.Historical (historicalLocalDayCodec, historicalMaybeLocalDayCodec)
import Control.Monad (forM_, unless)
import Data.Aeson (Value (..))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Either (isLeft)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Time.Calendar (fromGregorian)
import Generated.CalendarDays.CalendarJobs.Queue (CalendarJob (..), encodeCalendarJob, parseCalendarJob)
import Generated.CalendarDays.CalendarLookup.QueryContract (CalendarLookupQueryInput, CalendarLookupQueryResult)
import Generated.CalendarDays.CalendarStore.Codec
import Generated.CalendarDays.CalendarStore.Domain
import Generated.CalendarDays.CalendarStore.Harness (harnessAssertions)
import Generated.CalendarDays.Structural.CodecCompare.MaybeLocalDay (compareWithHistorical)
import Generated.CalendarDays.StructuralConformance (structuralConformanceAssertions)
import Keiro.Codec (eventType)
import Keiro.Codec.Structural qualified
import Keiro.Dsl.CodecCompare (CompareObservation (..), DecodeOutcome (..), FixtureVerdict (..), HistoricalCodec (..), classifyObservation, reportSucceeded)
import System.Exit (exitFailure)

main :: IO ()
main = do
  comparison <-
    compareWithHistorical
      historicalMaybeLocalDayCodec
      "test/conformance-calendar-days/fixtures/codec-compare"
  let assertions =
        [("structural/" <> label, passed) | (label, passed) <- structuralConformanceAssertions]
          <> harnessAssertions
          <> [ ("bare Day uses canonical calendar bytes", localDayWire),
               ("historical Aeson LocalDay writer matches generated bytes", historicalLocalDayParity),
               ("old Aeson readers reject new extended-year writes and require producer-last rollout", oldReaderNewWriterLimitation),
               ("invalid Gregorian dates are rejected", invalidDatesRejected),
               ("historical non-canonical spellings normalize", historicalSpellingsNormalize),
               ("a narrowed date reader is compatibility work", narrowedReaderRefused),
               ("a date-to-midnight conversion is compatibility work", midnightConversionRefused),
               ("root optional date fields treat omission and null alike", rootOptionalAbsenceEquivalence),
               ("non-optional date fields still reject omission", nonOptionalRootStrict),
               ("nested list and map dates round-trip", nestedRoundTrip),
               ("queue payloads preserve calendar-day mappings", queueRoundTrip),
               ("query contracts preserve calendar-day domain types", queryAgreement),
               ("historical MaybeLocalDay codec comparison succeeds", reportSucceeded comparison)
             ]
  forM_ assertions $ \(label, passed) ->
    putStrLn ((if passed then "PASS  " else "FAIL  ") <> label)
  unless (all snd assertions) exitFailure

localDayWire :: Bool
localDayWire =
  encodeLocalDayMapped value == String "2000-02-29"
    && decodeLocalDayMapped (String "2000-02-29") == Right value
    && encodeLocalDayMapped (LocalDay (fromGregorian 0 1 1)) == String "0000-01-01"
    && encodeLocalDayMapped (LocalDay (fromGregorian (-1) 1 1)) == String "-0001-01-01"
    && encodeLocalDayMapped (LocalDay (fromGregorian 12345678901234567890 6 30)) == String "12345678901234567890-06-30"
  where
    value = LocalDay (fromGregorian 2000 2 29)

historicalLocalDayParity :: Bool
historicalLocalDayParity =
  all
    (\(label, value) -> classifyObservation (EncodeObservation label (historicalLocalDayCodec.encode value) (encodeLocalDayMapped value)) == Right JsonParity)
    (NonEmpty.toList (Keiro.Codec.Structural.fixtureCases localDayFixtures))

oldReaderNewWriterLimitation :: Bool
oldReaderNewWriterLimitation =
  isLeft
    ( historicalLocalDayCodec.decode
        (encodeLocalDayMapped (LocalDay (fromGregorian 12345678901234567890 6 30)))
    )

invalidDatesRejected :: Bool
invalidDatesRejected =
  all (isLeft . decodeLocalDayMapped . String) ["1900-02-29", "2026-02-30", "2026-13-01", "2026-01-00"]

historicalSpellingsNormalize :: Bool
historicalSpellingsNormalize =
  decodeLocalDayMapped (String "+002000-02-29") == Right value
    && encodeLocalDayMapped value == String "2000-02-29"
    && decodeLocalDayMapped (String "00000000-01-01") == Right (LocalDay (fromGregorian 0 1 1))
  where
    value = LocalDay (fromGregorian 2000 2 29)

narrowedReaderRefused :: Bool
narrowedReaderRefused =
  case
      classifyObservation
        ( DecodeObservation
            "historical-plus-year.json"
            (String "+002000-02-29")
            (DecodedShape (String "2000-02-29"))
            (DecodeFailed "candidate reader rejected the historical spelling")
        )
    of
    Right (RequiresVersionWork _) -> True
    _ -> False

midnightConversionRefused :: Bool
midnightConversionRefused =
  case classifyObservation (EncodeObservation "midnight-coercion" (String "2000-02-29") (String "2000-02-29T00:00:00Z")) of
    Right (RequiresVersionWork _) -> True
    _ -> False

-- | Plan 295 found both spellings of absence in retained history -- omitted keys
-- and explicit nulls -- which historical Aeson decoding had always read as
-- 'Nothing'. A root 'Optional' mapped date field must therefore accept an
-- omitted key and decode it exactly as an explicit null.
rootOptionalAbsenceEquivalence :: Bool
rootOptionalAbsenceEquivalence =
  parseCalendarStoreEvent kind (deleteObjectField "optionalDay" encoded) == Right event
    && parseCalendarStoreEvent kind (insertObjectField "optionalDay" Null encoded) == Right event
  where
    event = DateStored (DateStoredData day (MaybeLocalDay Nothing) envelope)
    kind = eventType calendarStoreCodec event
    encoded = encodeCalendarStoreEvent event
    day = LocalDay (fromGregorian 2000 2 29)
    envelope = sampleEnvelope

-- | The equivalence above is scoped to root 'Optional' mapped fields. A
-- non-optional mapped root carries no absent spelling, so omitting it stays a
-- decode failure rather than defaulting.
nonOptionalRootStrict :: Bool
nonOptionalRootStrict =
  isLeft (parseCalendarStoreEvent kind (deleteObjectField "day" encoded))
    && isLeft (parseCalendarStoreEvent kind (deleteObjectField "envelope" encoded))
  where
    event = DateStored (DateStoredData day (MaybeLocalDay Nothing) envelope)
    kind = eventType calendarStoreCodec event
    encoded = encodeCalendarStoreEvent event
    day = LocalDay (fromGregorian 2000 2 29)
    envelope = sampleEnvelope

nestedRoundTrip :: Bool
nestedRoundTrip = decodeCalendarEnvelopeMapped (encodeCalendarEnvelopeMapped sampleEnvelope) == Right sampleEnvelope

queueRoundTrip :: Bool
queueRoundTrip = parseCalendarJob (encodeCalendarJob payload) == Right payload
  where
    payload = CalendarJob (LocalDay (fromGregorian 2000 2 29)) (MaybeLocalDay Nothing) sampleEnvelope

queryAgreement :: Bool
queryAgreement =
  queryInputIdentity (MaybeLocalDay (Just (fromGregorian 2000 2 29))) == MaybeLocalDay (Just (fromGregorian 2000 2 29))
    && queryResultIdentity sampleEnvelope == sampleEnvelope

queryInputIdentity :: CalendarLookupQueryInput -> MaybeLocalDay
queryInputIdentity = id

queryResultIdentity :: CalendarLookupQueryResult -> CalendarEnvelope
queryResultIdentity = id

sampleEnvelope :: CalendarEnvelope
sampleEnvelope =
  CalendarEnvelope
    (fromGregorian 2000 2 29)
    Nothing
    (MaybeLocalDay (Just (fromGregorian 0 1 1)))
    [fromGregorian 1900 2 28, fromGregorian 1900 3 1]
    (Map.fromList [("extended", fromGregorian 12345678901234567890 6 30)])

deleteObjectField :: Key.Key -> Value -> Value
deleteObjectField key (Object value) = Object (KeyMap.delete key value)
deleteObjectField _ value = value

insertObjectField :: Key.Key -> Value -> Value -> Value
insertObjectField key inserted (Object value) = Object (KeyMap.insert key inserted value)
insertObjectField _ _ value = value