keiki-codec-json 0.1.0.0 → 0.2.0.0

raw patch · 26 files changed

+1394/−130 lines, 26 filesdep +scientificdep ~keikidep ~keiki-codec-jsonPVP ok

version bump matches the API change (PVP)

Dependencies added: scientific

Dependency ranges changed: keiki, keiki-codec-json

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−0
• README.md +98/−7
• keiki-codec-json.cabal +18/−7
• src/Keiki/Codec/JSON.hs +49/−2
• src/Keiki/Codec/JSON/Event.hs +425/−33
• src/Keiki/Codec/JSON/TH.hs +23/−31
• test/Keiki/Codec/JSON/Fixtures.hs +31/−0
• test/Keiki/Codec/JSON/GoldenFileSpec.hs +266/−0
• test/Keiki/Codec/JSON/GoldenSpec.hs +10/−12
• test/Keiki/Codec/JSON/PropSpec.hs +69/−22
• test/Keiki/Codec/JSON/THEventEvolutionSpec.hs +227/−0
• test/Keiki/Codec/JSON/THEventSpec.hs +112/−16
• test/Spec.hs +15/−0
• test/golden/event/item-added.pre-defaults.json +1/−0
• test/golden/event/item-added.v1.json +1/−0
• test/golden/event/order-cancelled.v1.json +1/−0
• test/golden/event/order-placed.v1.json +1/−0
• test/golden/event/quantity-recorded.v1.json +1/−0
• test/golden/event/quantity-recorded.v2.json +1/−0
• test/golden/exemplar-regfile.encoding.json +1/−0
• test/golden/exemplar-regfile.value.json +1/−0
• test/golden/exemplar-shape.json +1/−0
• test/golden/maybe-regfile-just.encoding.json +1/−0
• test/golden/maybe-regfile-just.value.json +1/−0
• test/golden/maybe-regfile-nothing.encoding.json +1/−0
• test/golden/maybe-regfile-nothing.value.json +1/−0

@@ -9,6 +9,44 @@ ## [Unreleased]  +## [0.2.0.0] — 2026-07-13++### Added++- Event-codec schema evolution through pinned constructor wire kinds,+  default-on-missing payload decoding, and a compile-time-complete chain of+  one-envelope-to-one-envelope upcasters.+- `fieldCodec`, a strict smart constructor for `FieldCodec`, plus generated+  `<prefix>SchemaVersion` bindings.++### Changed++- **Breaking for invalid schemas:** `RegFileToJSON` now rejects duplicate slot+  names at compile time through keiki's canonical `DistinctNames` invariant,+  preventing Value-path data loss and duplicate streaming keys.+- Encoding now documents and pins the existing fully-initialized-register+  precondition. Unwritten `emptyRegFile` slots throw a slot-named `ErrorCall`;+  keiro already snapshots only fully populated register files, so it needs no+  source change.+- **Breaking:** snapshot shape hashes now use keiki's pinned built-in type names.+  Every non-empty shape hash changes once; stores keyed by an old hash ignore that+  snapshot and replay from the event log. Keiro already treats this mismatch as a+  benign cache miss.+- Container slot types now require their arguments to have+  `CanonicalTypeName`, not merely `Typeable`, so user-defined types may need to+  derive or define that class. This makes application overrides propagate through+  `Maybe`, lists, `Either`, and tuples.+- **Breaking:** `EventCodecOptions` now also carries `kindOverrides`,+  `versionFieldName`, `currentVersion`, and `upcasters`.+- **Breaking:** `FieldCodec` gains the `fcOnMissing` field. Positional+  construction should be replaced with `fieldCodec` and a record update when a+  missing-key default is required.+- **Breaking:** generated event envelopes now contain an in-band `"v"` field;+  version-absent historical objects decode as version 1.+- **Breaking:** generated `EventTypes` and `KindMap` bindings contain resolved+  wire kinds, including pinned values, rather than assuming constructor names.++ ## [0.1.0.0] — 2026-06-07  Initial Hackage release. Co-released with `keiki-0.1.0.0`; this

@@ -90,6 +90,26 @@ (non-record-syntax) constructors, and type synonyms are rejected at splice time with a precise error message. +## Register-file wire rules++Every register slot must be written before encoding. `emptyRegFile` is an+initialization scaffold whose unwritten slots throw an `ErrorCall` beginning with+`uninit:` when read or encoded; it is not an encodable snapshot. On the streaming+path that exception can surface after earlier bytes have already been emitted, so+snapshot only fully hydrated aggregates.++Every register slot is present in the JSON object. A `Nothing` slot encodes as+explicit JSON `null`; omitting its key is an error, not another spelling of+`Nothing`. A nested optional value is lossy under aeson's standard instances:+`Just Nothing :: Maybe (Maybe a)` and outer `Nothing` both encode as `null` and+decode as outer `Nothing`. Avoid nested-`Maybe` slots when that distinction+matters, or wrap the inner optional value in a newtype with explicit JSON+instances.++The Value encoder emits aeson's object-key order, while the streaming Encoding+path emits slot-list order. Their bytes may differ, but both decode to the same+register file.+ ## Deriving an event codec skeleton  A service that stores its events as JSON usually hand-writes a@@ -109,9 +129,10 @@ import Data.Text (Text) import Keiki.Codec.JSON.Event   ( EventCodecOptions (..)-  , FieldCodec (..)+  , FieldCodec (fcOnMissing)   , defaultEventCodecOptions   , deriveEventCodecSkeleton+  , fieldCodec   )  newtype OrderId = OrderId Int deriving stock (Eq, Show)@@ -138,7 +159,7 @@ $(deriveEventCodecSkeleton     defaultEventCodecOptions       { fieldCodecOverrides =-          Map.fromList [("orderId", FieldCodec 'orderIdToJSON 'orderIdFromJSON)]+          Map.fromList [("orderId", fieldCodec 'orderIdToJSON 'orderIdFromJSON)]       , passthroughFields = Set.fromList ["qty", "trackingNo"]       }     ''OrderEvent)@@ -147,15 +168,18 @@ --   orderEventFromJSON   :: Aeson.Value -> Either String OrderEvent --   orderEventEventTypes :: [Text] --   orderEventKindMap    :: [(Text, Text)]+--   orderEventSchemaVersion :: Int ```  Each constructor encodes to an object carrying a `"kind"` discriminator-(its constructor name) plus one entry per payload field, so+(its constructor name unless pinned) and a `"v"` schema version, plus one+entry per payload field, so `orderEventToJSON (Placed (PlacedData (OrderId 7) 3))` is-`{"kind":"Placed","orderId":"ord-7","qty":3}` — note `orderId` is the-override's output, not a generic `Int`. The `orderEventEventTypes` /-`orderEventKindMap` bindings are plain `Text` (no Keiro dependency) so a-downstream can feed them to Keiro's `Codec.eventTypes`.+`{"kind":"Placed","v":1,"orderId":"ord-7","qty":3}` — note `orderId`+is the override's output, not a generic `Int`. The+`orderEventEventTypes` / `orderEventKindMap` bindings contain the resolved+wire kinds as plain `Text` (no Keiro dependency), and+`orderEventSchemaVersion` contains the configured current version.  **No silent generic fallback.** Each payload field is encoded by *name*: an override (`fieldCodecOverrides`), a passthrough using the field's own@@ -170,6 +194,73 @@ Constructors that are multi-argument, use record syntax directly, or are GADT/infix are rejected at splice time with a precise message; wrap a single record payload type instead (`Placed PlacedData`).++### Evolving an event schema++There are three common changes, each with a distinct codec move.++1. **Add a payload field without bumping the version.** For an optional+   field such as `note :: Maybe Text`, add `"note"` to+   `passthroughFields`; a missing key decodes as `Nothing`, while an+   explicit JSON `null` also follows aeson's normal `Maybe` decoder. For a+   non-`Maybe` field, provide a named default constant through the override:++   ```haskell+   defaultPriority :: Priority+   defaultPriority = NormalPriority++   priorityCodec :: FieldCodec+   priorityCodec =+     (fieldCodec 'priorityToJSON 'priorityFromJSON)+       { fcOnMissing = Just 'defaultPriority }+   ```++   Put `priorityCodec` in `fieldCodecOverrides`. Keep `currentVersion`+   unchanged: this is an additive compatibility rule, not a structural+   migration. Required fields without either form of default still fail with+   `missing field: <name>`.++2. **Rename a Haskell constructor without changing stored bytes.** Pin the+   renamed constructor to its historical discriminator:++   ```haskell+   kindOverrides = Map.fromList [("OrderPlaced", "Placed")]+   ```++   Override keys are current constructor names. The splice rejects unknown+   keys and duplicate resolved wire kinds, while encoding, decoding,+   `EventTypes`, and `KindMap` all use the pinned wire value.++3. **Restructure a payload.** Increment `currentVersion` and register one+   whole-envelope upcaster for every historical step:++   ```haskell+   upcastOrderV1 :: Aeson.Value -> Either String Aeson.Value+   upcastOrderV1 = ... -- rewrite a version-1 object into version-2 shape++   currentVersion = 2+   upcasters = [(1, 'upcastOrderV1)]+   ```++   An absent `"v"` is version 1. Before constructor dispatch, the decoder+   runs every rung from the stored version to the current version. For+   `currentVersion = n`, the splice requires exactly the source versions+   `[1 .. n - 1]`; gaps, duplicates, and out-of-range entries fail at compile+   time. A rung is one-envelope-to-one-envelope. If one historical event must+   split into several current events, do that in the application's event-store+   adapter as described in+   [`docs/research/schema-evolution.md`](../docs/research/schema-evolution.md).++Unknown object keys are intentionally ignored by the event decoder so additive+deployments can overlap. This differs from the RegFile snapshot decoder, which+rejects extra keys because a snapshot must match one exact register shape.++The in-band `"v"` is opt-in version ownership for applications that have no+outer event envelope. If an application already owns out-of-band metadata — for+example, a keiro-style `schemaVersion` beside the payload — keep this codec's+`currentVersion = 1` and evolve at that outer layer. Running both schemes with+different version numbers is a configuration error; neither layer detects the+disagreement for the other.  ## When to use the streaming encoder 

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               keiki-codec-json-version:            0.1.0.0+version:            0.2.0.0 synopsis:           Optional JSON codec for keiki's RegFile. description:   Sibling package to keiki providing a JSON encoder, decoder, and@@ -43,8 +43,16 @@   CONTRIBUTING.md   README.md -extra-source-files: bench/baseline.csv+extra-source-files:+  bench/baseline.csv+  test/golden/*.json+  test/golden/event/*.json +source-repository head+  type:     git+  location: https://github.com/shinzui/keiki.git+  subdir:   keiki-codec-json+ common warnings   ghc-options:     -Wall -Wcompat -Widentities -Wincomplete-record-updates@@ -73,7 +81,8 @@     , aeson             ^>=2.2     , base              ^>=4.21     , containers        ^>=0.7-    , keiki             ^>=0.1+    , keiki             ^>=0.2+    , scientific        ^>=0.3     , template-haskell  ^>=2.23     , text              ^>=2.1 @@ -87,8 +96,8 @@     , base              ^>=4.21     , bytestring        ^>=0.12     , deepseq           ^>=1.5-    , keiki             ^>=0.1-    , keiki-codec-json  ^>=0.1+    , keiki             ^>=0.2+    , keiki-codec-json  ^>=0.2     , tasty-bench       ^>=0.4  || ^>=0.5     , text              ^>=2.1 @@ -101,9 +110,11 @@   main-is:        Spec.hs   other-modules:     Keiki.Codec.JSON.Fixtures+    Keiki.Codec.JSON.GoldenFileSpec     Keiki.Codec.JSON.GoldenSpec     Keiki.Codec.JSON.PropSpec     Keiki.Codec.JSON.SensitivitySpec+    Keiki.Codec.JSON.THEventEvolutionSpec     Keiki.Codec.JSON.THEventSpec     Keiki.Codec.JSON.THSpec @@ -113,8 +124,8 @@     , bytestring            ^>=0.12     , containers            ^>=0.7     , hspec                 ^>=2.11-    , keiki                 ^>=0.1-    , keiki-codec-json      ^>=0.1+    , keiki                 ^>=0.2+    , keiki-codec-json      ^>=0.2     , QuickCheck            ^>=2.15     , quickcheck-instances  ^>=0.3     , text                  ^>=2.1

@@ -20,6 +20,31 @@ -- snapshots (catches structural drift, EP-36 §4 cases #1–9); the -- codec serialises the eligible ones. --+-- == Wire-format rules+--+-- Every slot must have been written before encoding. Encoding a register file+-- seeded by @Keiki.Generics.emptyRegFile@ but not fully initialized throws an+-- 'Control.Exception.ErrorCall' whose message starts with @uninit:@. On the+-- streaming path the exception can surface after an earlier part of the object+-- has already been emitted, so snapshot only fully hydrated aggregates.+--+-- Slot names must also be pairwise distinct. 'RegFileToJSON' applies the+-- canonical @Keiki.Internal.Slots.DistinctNames (Keiki.Internal.Slots.Names+-- rs)@ invariant at compile time. Without it, the Value path would silently+-- retain only one duplicate key, the streaming path would emit the key twice,+-- and decoding could never populate the second slot.+--+-- A @Nothing@ slot is present as explicit JSON @null@. Omitting the key is+-- not equivalent: 'regFileFromJSON' rejects every absent slot. A nested+-- @Maybe@ is not faithfully representable by aeson's standard instances:+-- @Just Nothing@ and @Nothing@ both encode as @null@ and decode as outer+-- @Nothing@. Avoid @Maybe (Maybe a)@ slots when that distinction matters, or+-- wrap the inner optional value in a newtype with explicit JSON instances.+--+-- The 'Aeson.Value' path serializes object keys in aeson's KeyMap order+-- (alphabetical with aeson 2.2), while 'regFileToEncoding' preserves slot-list+-- order. The byte streams may differ; both decode to the same register file.+-- -- == Slot-value size guidance (P11) -- -- keiki's per-slot dispatch overhead is microseconds at any realistic@@ -57,6 +82,7 @@ import Data.Proxy (Proxy (..)) import GHC.TypeLits (KnownSymbol, symbolVal) import Keiki.Core (RegFile (..), Slot)+import Keiki.Internal.Slots (DistinctNames, Names)  -- * Internal walker ----------------------------------------------------------- @@ -134,6 +160,10 @@ class (RegFileWalk rs) => RegFileToJSON (rs :: [Slot]) where   -- | Encode a slot list as a JSON object whose keys are the slot   -- symbols, in slot-list order.+  --+  -- Precondition: every slot must have been written. An unwritten+  -- @Keiki.Generics.emptyRegFile@ slot throws an+  -- 'Control.Exception.ErrorCall' whose message starts with @uninit:@.   regFileToJSON :: RegFile rs -> Aeson.Value   regFileToJSON = Aeson.object . regFilePairs @@ -142,6 +172,11 @@   -- 'Aeson.Value' intermediate. Recommended for RegFiles with   -- multi-MB slot values; see the module header's "Slot-value size   -- guidance".+  --+  -- Precondition: every slot must have been written. An unwritten+  -- @Keiki.Generics.emptyRegFile@ slot throws an+  -- 'Control.Exception.ErrorCall' whose message starts with @uninit:@,+  -- potentially after earlier bytes have been emitted downstream.   regFileToEncoding :: RegFile rs -> Aeson.Encoding   regFileToEncoding = Aeson.pairs . regFileSeries @@ -165,5 +200,17 @@ -- coverage is a 'RegFileToJSON'. Users do not write instances of this -- class themselves; the inductive 'RegFileWalk' instances (one for -- @'[]@, one for @\'(s, t) \': rs@) cover every slot list whose--- component types carry 'Aeson.ToJSON' and 'Aeson.FromJSON'.-instance (RegFileWalk rs) => RegFileToJSON rs+-- component types carry 'Aeson.ToJSON' and 'Aeson.FromJSON'. The+-- 'DistinctNames' constraint rejects duplicate slot symbols before either+-- encoder can lose data or emit ambiguous JSON.+--+-- == Negative-test procedure (manual)+--+-- With @DataKinds@ and @TypeApplications@ enabled, this definition must fail+-- to compile with @register file declares slot "x" more than once@:+--+-- @+-- duplicateCodec :: RegFile '[ '("x", Int), '("x", Bool)] -> Aeson.Value+-- duplicateCodec = regFileToJSON+-- @+instance (RegFileWalk rs, DistinctNames (Names rs)) => RegFileToJSON rs

@@ -16,28 +16,59 @@ -- >   | Cancelled -- >   deriving stock (Eq, Show) ----- the splice @$(deriveEventCodecSkeleton opts ''OrderEvent)@ emits four+-- the splice @$(deriveEventCodecSkeleton opts ''OrderEvent)@ emits five -- top-level bindings (prefix derived by lower-casing the first letter of the -- type name): -- -- > orderEventToJSON     :: OrderEvent -> Aeson.Value -- > orderEventFromJSON   :: Aeson.Value -> Either String OrderEvent--- > orderEventEventTypes :: [Data.Text.Text]                    -- ctor names, in order+-- > orderEventEventTypes :: [Data.Text.Text]                    -- wire kinds, in order -- > orderEventKindMap    :: [(Data.Text.Text, Data.Text.Text)]  -- (ctor, kind)+-- > orderEventSchemaVersion :: Int -- -- Each constructor encodes to a JSON object carrying a @"kind"@--- discriminator (the constructor name) plus one entry per payload field.--- The decoder reads @"kind"@, branches, and reassembles the payload field--- by field.+-- discriminator (the pinned wire kind, or the constructor name by default)+-- and an in-band @"v"@ schema version, plus one entry per payload field. --+-- Decoding follows a fixed pipeline: validate the stored version (an absent+-- @"v"@ means version 1), run every required whole-object upcaster in order,+-- dispatch on the migrated @"kind"@, then decode payload fields and apply any+-- missing-key defaults. Upcasters run before dispatch, so a structural change+-- may rewrite the discriminator as well as payload keys.+--+-- == Evolving an event schema+--+-- For an additive field, keep 'currentVersion' unchanged and either make the+-- field a syntactic @Maybe t@ passthrough or give its 'FieldCodec' an+-- 'fcOnMissing' constant. For a structural payload change, increment+-- 'currentVersion' and add the complete next rung to 'upcasters'. For a Haskell+-- constructor rename, preserve its old wire discriminator with 'kindOverrides'.+--+-- Each upcaster maps one envelope to one envelope. Splitting one historical+-- event into several current events remains an application-boundary concern;+-- see @docs/research/schema-evolution.md@ for that wider contract. The pure+-- @keiki@ core remains version-agnostic.+--+-- == Unknown object keys+--+-- Event decoding intentionally ignores keys that are not current payload or+-- envelope fields. This permits old and new readers to coexist during additive+-- deployments. The snapshot-oriented @RegFileToJSON@ decoder instead rejects+-- extra keys because a register snapshot must match one exact shape; the two+-- codecs serve different compatibility contracts.+-- -- == No silent generic fallback (the anti-drift property) -- -- A payload field is encoded one of three ways, chosen by /field name/: -- --   * if its name is a key of 'fieldCodecOverrides', the author-supplied---     'FieldCodec' functions are spliced in;+--     'FieldCodec' functions are spliced in; an absent key uses+--     'fcOnMissing' when supplied and otherwise remains an error; --   * else if its name is in 'passthroughFields', the field's own---     'Aeson.ToJSON' \/ 'Aeson.FromJSON' instances are used;+--     'Aeson.ToJSON' \/ 'Aeson.FromJSON' instances are used. A field whose+--     reified type is syntactically @Maybe t@ decodes an absent key as+--     'Nothing'; type synonyms are not expanded, and all other passthrough+--     fields remain strict; --   * otherwise the field is /unhandled/, and 'onMissingCodec' decides: --     'FailAtCompileTime' (the default) aborts the splice listing every --     unhandled field, while 'EmitTodoBindings' emits a clearly-named@@ -57,12 +88,13 @@ -- == Negative-test procedure (manual) -- -- See @Keiki.Codec.JSON.THEventSpec@ for the documented procedure that--- exercises the 'FailAtCompileTime' and 'EmitTodoBindings' behaviours; the--- two cases cannot live as a passing unit test because one is a compile--- failure.+-- exercises compile-time configuration failures and the 'EmitTodoBindings'+-- behaviour. Those checks cannot all live as passing unit tests because their+-- expected result is a compile failure. module Keiki.Codec.JSON.Event   ( -- * Options     FieldCodec (..),+    fieldCodec,     OnMissingCodec (..),     EventCodecOptions (..),     defaultEventCodecOptions,@@ -73,7 +105,10 @@      -- * Runtime helpers (referenced by generated code; not usually called directly)     lookupField,+    lookupFieldMaybe,     lookupText,+    lookupVersion,+    migrateEnvelope,     aesonResultToEither,   ) where@@ -82,9 +117,10 @@ import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.Char (toLower)-import Data.List (intercalate)+import Data.List (group, intercalate, sort, sortOn, (\\)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map+import Data.Scientific qualified as Scientific import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text)@@ -98,12 +134,24 @@ -- --   * 'fcEncode' names a function @fieldType -> Aeson.Value@ (e.g. @idText@); --   * 'fcDecode' names a function @Aeson.Value -> Either String fieldType@---     (e.g. @parseIdText@).+--     (e.g. @parseIdText@);+--   * 'fcOnMissing' optionally names a top-level /constant/ of the field type,+--     used only when the JSON key is absent. data FieldCodec = FieldCodec   { fcEncode :: Name,-    fcDecode :: Name+    fcDecode :: Name,+    fcOnMissing :: Maybe Name   } +-- | Construct a strict field codec with no missing-key default.+fieldCodec :: Name -> Name -> FieldCodec+fieldCodec encodeName decodeName =+  FieldCodec+    { fcEncode = encodeName,+      fcDecode = decodeName,+      fcOnMissing = Nothing+    }+ -- | What to do for a payload field whose name appears in neither -- 'fieldCodecOverrides' nor 'passthroughFields'. data OnMissingCodec@@ -123,11 +171,25 @@     passthroughFields :: Set String,     -- | the discriminator key; default @"kind"@     kindFieldName :: String,+    -- | constructor base name to stable wire kind. Constructors omitted from+    --     this map use their Haskell name. Override keys and resolved wire kinds+    --     are validated when the splice runs.+    kindOverrides :: Map String String,+    -- | the in-band schema-version key; default @"v"@+    versionFieldName :: String,+    -- | current schema version stamped by the encoder; must be at least @1@+    currentVersion :: Int,+    -- | one whole-envelope migration per historical from-version. A version+    --     @n@ function upgrades to version @n + 1@; the splice requires exact+    --     coverage of @[1 .. currentVersion - 1]@.+    upcasters :: [(Int, Name)],     -- | behaviour for unhandled fields; default 'FailAtCompileTime'     onMissingCodec :: OnMissingCodec   } --- | Empty overrides, empty passthrough, @kindFieldName = "kind"@,+-- | Empty field and kind overrides, empty passthrough,+-- @kindFieldName = "kind"@, @versionFieldName = "v"@,+-- @currentVersion = 1@, no upcasters, and -- @onMissingCodec = 'FailAtCompileTime'@. defaultEventCodecOptions :: EventCodecOptions defaultEventCodecOptions =@@ -135,6 +197,10 @@     { fieldCodecOverrides = Map.empty,       passthroughFields = Set.empty,       kindFieldName = "kind",+      kindOverrides = Map.empty,+      versionFieldName = "v",+      currentVersion = 1,+      upcasters = [],       onMissingCodec = FailAtCompileTime     } @@ -146,6 +212,10 @@   Just v -> Right v   Nothing -> Left ("missing field: " <> Key.toString k) +-- | Total object lookup: 'Nothing' when the key is absent.+lookupFieldMaybe :: Key.Key -> Aeson.Object -> Maybe Aeson.Value+lookupFieldMaybe = KeyMap.lookup+ -- | Look a key up and require its value to be a JSON string. lookupText :: Key.Key -> Aeson.Object -> Either String Text lookupText k o = do@@ -154,6 +224,47 @@     Aeson.String t -> Right t     _ -> Left ("field " <> Key.toString k <> ": expected a string") +-- | Read an in-band schema version. An absent key means version @1@; a+-- present value must be an integral JSON number representable as an 'Int'.+lookupVersion :: Key.Key -> Aeson.Object -> Either String Int+lookupVersion k o = case KeyMap.lookup k o of+  Nothing -> Right 1+  Just (Aeson.Number number) ->+    maybe+      (Left expectedInteger)+      Right+      (Scientific.toBoundedInteger number)+  Just _ -> Left expectedInteger+  where+    expectedInteger =+      "field " <> Key.toString k <> ": expected an integer schema version"++-- | Replay a compile-time-complete chain from the stored version to the+-- current version. Rungs run in ascending source-version order; the only+-- expected runtime failure is a rung rejecting its input.+migrateEnvelope ::+  Int ->+  [(Int, Aeson.Value -> Either String Aeson.Value)] ->+  Int ->+  Aeson.Value ->+  Either String Aeson.Value+migrateEnvelope targetVersion chain storedVersion =+  go applicableRungs+  where+    applicableRungs =+      [ rung+      | rung@(fromVersion, _) <- sortOn fst chain,+        fromVersion >= storedVersion,+        fromVersion < targetVersion+      ]++    go [] value = Right value+    go ((fromVersion, upcast) : rest) value =+      case upcast value of+        Left message ->+          Left ("upcaster from version " <> show fromVersion <> ": " <> message)+        Right nextValue -> go rest nextValue+ -- | Adapt aeson's 'Aeson.Result' to @Either String@. aesonResultToEither :: Aeson.Result a -> Either String a aesonResultToEither (Aeson.Success a) = Right a@@ -180,6 +291,10 @@           <> " has no constructors; pass an event sum type."     _ -> pure () +  validateWireKinds opts tyName ctors+  validateVersionEnvelope opts ctors+  validateUpcasters opts+   -- No-silent-fallback safety net: classify each payload field; an   -- unhandled field is one in neither overrides nor passthrough.   let unhandled =@@ -211,6 +326,7 @@       fromJSONN = mkName (prefix <> "FromJSON")       eventTypesN = mkName (prefix <> "EventTypes")       kindMapN = mkName (prefix <> "KindMap")+      schemaVersionN = mkName (prefix <> "SchemaVersion")       tyT = conT tyName    -- Encoder: one clause per constructor.@@ -221,13 +337,14 @@   vVar <- newName "v"   oVar <- newName "o"   kVar <- newName "kind"+  versionVar <- newName "version"   fromSig <- sigD fromJSONN [t|Aeson.Value -> Either String $tyT|]   fromDef <-     funD       fromJSONN       [ clause           [varP vVar]-          (normalB (decoderBody opts prefix vVar oVar kVar ctors))+          (normalB (decoderBody opts prefix vVar oVar kVar versionVar ctors))           []       ] @@ -240,7 +357,7 @@           []           ( normalB               ( listE-                  [ [|T.pack $(stringE (nameBase (ecCtorName ec)))|]+                  [ [|T.pack $(stringE (wireKindOf opts (ecCtorName ec)))|]                   | ec <- ctors                   ]               )@@ -255,14 +372,22 @@           []           ( normalB               ( listE-                  [ [|(T.pack $(stringE nm), T.pack $(stringE nm))|]-                  | ec <- ctors,-                    let nm = nameBase (ecCtorName ec)+                  [ [|+                      ( T.pack $(stringE (nameBase (ecCtorName ec))),+                        T.pack $(stringE (wireKindOf opts (ecCtorName ec)))+                      )+                      |]+                  | ec <- ctors                   ]               )           )           []       ]+  svSig <- sigD schemaVersionN [t|Int|]+  svDef <-+    funD+      schemaVersionN+      [clause [] (normalB (litE (IntegerL (fromIntegral (currentVersion opts))))) []]    pure $     todoBindings@@ -273,7 +398,9 @@            etSig,            etDef,            kmSig,-           kmDef+           kmDef,+           svSig,+           svDef          ]  -- * Encoder generation -------------------------------------------------------@@ -284,11 +411,14 @@   Nothing ->     clause       [conP (ecCtorName ec) []]-      (normalB [|Aeson.object [$(kindPair)]|])+      (normalB [|Aeson.object [$(kindPair), $(versionPair)]|])       []   Just (_pc, fields) -> do     pVar <- newName "p"-    let pairs = kindPair : map (fieldPair opts (ecCtorName ec) pVar) fields+    let pairs =+          kindPair+            : versionPair+            : map (fieldPair opts (ecCtorName ec) pVar) fields     clause       [conP (ecCtorName ec) [varP pVar]]       (normalB [|Aeson.object $(listE pairs)|])@@ -297,8 +427,13 @@     kindPair =       [|         $(keyE (kindFieldName opts))-          Aeson..= (T.pack $(stringE (nameBase (ecCtorName ec))) :: Text)+          Aeson..= (T.pack $(stringE (wireKindOf opts (ecCtorName ec))) :: Text)         |]+    versionPair =+      [|+        $(keyE (versionFieldName opts))+          Aeson..= ($(litE (IntegerL (fromIntegral (currentVersion opts)))) :: Int)+        |]  -- | One @"field" .= <encoded>@ pair. fieldPair :: EventCodecOptions -> Name -> Name -> (String, Name, Type) -> Q Exp@@ -318,17 +453,17 @@  -- | The full @fromJSON@ body: @case v of Object o -> ...; _ -> Left ...@. decoderBody ::-  EventCodecOptions -> String -> Name -> Name -> Name -> [EvCtor] -> Q Exp-decoderBody opts prefix vVar oVar kVar ctors =+  EventCodecOptions -> String -> Name -> Name -> Name -> Name -> [EvCtor] -> Q Exp+decoderBody opts prefix vVar oVar kVar versionVar ctors =   caseE     (varE vVar)     [ match         (conP 'Aeson.Object [varP oVar])         ( normalB             ( infixE-                (Just [|lookupText $(keyE (kindFieldName opts)) $(varE oVar)|])+                (Just [|lookupVersion $(keyE (versionFieldName opts)) $(varE oVar)|])                 (varE '(>>=))-                (Just (lamE [varP kVar] (dispatch opts oVar kVar ctors)))+                (Just (lamE [varP versionVar] versionGuard))             )         )         [],@@ -337,20 +472,104 @@         (normalB [|Left $(stringE (prefix <> ": expected a JSON object"))|])         []     ]+  where+    currentVersionE = litE (IntegerL (fromIntegral (currentVersion opts)))+    dispatchMigrated migratedObjectVar =+      infixE+        ( Just+            [|+              lookupText+                $(keyE (kindFieldName opts))+                $(varE migratedObjectVar)+              |]+        )+        (varE '(>>=))+        ( Just+            ( lamE+                [varP kVar]+                (dispatch opts migratedObjectVar kVar ctors)+            )+        )+    migratedObjectCase migratedValueVar migratedObjectVar =+      caseE+        (varE migratedValueVar)+        [ match+            (conP 'Aeson.Object [varP migratedObjectVar])+            (normalB (dispatchMigrated migratedObjectVar))+            [],+          match+            wildP+            (normalB [|Left $(stringE (prefix <> ": expected a JSON object"))|])+            []+        ]+    migrateCurrent migratedValueVar migratedObjectVar =+      infixE+        ( Just+            [|+              migrateEnvelope+                ($currentVersionE :: Int)+                $(upcasterChainE opts)+                $(varE versionVar)+                (Aeson.Object $(varE oVar))+              |]+        )+        (varE '(>>=))+        ( Just+            ( lamE+                [varP migratedValueVar]+                (migratedObjectCase migratedValueVar migratedObjectVar)+            )+        )+    versionGuard = do+      migratedValueVar <- newName "migratedValue"+      migratedObjectVar <- newName "migratedObject"+      [|+        if $(varE versionVar) < 1+          then Left ("invalid event schema version: " <> show $(varE versionVar))+          else+            if $(varE versionVar) > ($currentVersionE :: Int)+              then+                Left+                  ( "event schema version "+                      <> show $(varE versionVar)+                      <> " is ahead of codec version "+                      <> show ($currentVersionE :: Int)+                  )+              else $(migrateCurrent migratedValueVar migratedObjectVar)+        |] +upcasterChainE :: EventCodecOptions -> Q Exp+upcasterChainE opts =+  listE+    [ [|($(litE (IntegerL (fromIntegral fromVersion))) :: Int, $(varE upcastName))|]+    | (fromVersion, upcastName) <- sortOn fst (upcasters opts)+    ]+ -- | Nested @if kind == "C" then <build C> else ...@ ending in an -- unknown-kind 'Left'. dispatch :: EventCodecOptions -> Name -> Name -> [EvCtor] -> Q Exp-dispatch opts oVar kVar =+dispatch opts oVar kVar ctors =   foldr     ( \ec elseQ ->         [|-          if $(varE kVar) == T.pack $(stringE (nameBase (ecCtorName ec)))+          if $(varE kVar) == T.pack $(stringE (wireKindOf opts (ecCtorName ec)))             then $(buildCtorDecode opts oVar ec)             else $elseQ           |]     )-    [|Left ("unknown event kind: " <> T.unpack $(varE kVar))|]+    [|+      Left+        ( "unknown event kind: "+            <> T.unpack $(varE kVar)+            <> $(stringE expectedKinds)+        )+      |]+    ctors+  where+    expectedKinds =+      " (expected one of: "+        <> intercalate ", " (map (wireKindOf opts . ecCtorName) ctors)+        <> ")"  -- | Decode one constructor's payload: @C \<$> (PayloadCtor \<$> d1 \<*> ...)@. buildCtorDecode :: EventCodecOptions -> Name -> EvCtor -> Q Exp@@ -369,13 +588,33 @@  -- | @Either String fieldType@ decoder for one field. decodeFieldExpr :: EventCodecOptions -> Name -> Name -> (String, Name, Type) -> Q Exp-decodeFieldExpr opts oVar ctorName (fn, _sel, _ft) =+decodeFieldExpr opts oVar ctorName (fn, _sel, ft) =   let getV = [|lookupField $(keyE fn) $(varE oVar)|]    in case classify opts fn of-        Override fc -> [|$(varE (fcDecode fc)) =<< $getV|]-        Passthrough -> [|(aesonResultToEither . Aeson.fromJSON) =<< $getV|]+        Override fc -> case fcOnMissing fc of+          Nothing -> [|$(varE (fcDecode fc)) =<< $getV|]+          Just missingDefault ->+            [|+              case lookupFieldMaybe $(keyE fn) $(varE oVar) of+                Nothing -> Right $(varE missingDefault)+                Just fieldValue -> $(varE (fcDecode fc)) fieldValue+              |]+        Passthrough+          | isSyntacticMaybe ft ->+              [|+                case lookupFieldMaybe $(keyE fn) $(varE oVar) of+                  Nothing -> Right Nothing+                  Just fieldValue -> aesonResultToEither (Aeson.fromJSON fieldValue)+                |]+          | otherwise -> [|(aesonResultToEither . Aeson.fromJSON) =<< $getV|]         Unhandled -> [|$(varE (todoName ctorName fn)) =<< $getV|] +isSyntacticMaybe :: Type -> Bool+isSyntacticMaybe (SigT ty _) = isSyntacticMaybe ty+isSyntacticMaybe (ParensT ty) = isSyntacticMaybe ty+isSyntacticMaybe (AppT (ConT maybeName) _) = maybeName == ''Maybe+isSyntacticMaybe _ = False+ -- * TODO bindings ------------------------------------------------------------  -- | The placeholder binding name for an unhandled field.@@ -418,6 +657,159 @@ isUnhandled opts fn =   not (fn `Map.member` fieldCodecOverrides opts)     && not (fn `Set.member` passthroughFields opts)++-- * Wire-kind validation ----------------------------------------------------++wireKindOf :: EventCodecOptions -> Name -> String+wireKindOf opts ctorName =+  Map.findWithDefault ctorBase ctorBase (kindOverrides opts)+  where+    ctorBase = nameBase ctorName++validateWireKinds :: EventCodecOptions -> Name -> [EvCtor] -> Q ()+validateWireKinds opts tyName ctors = do+  case unknownOverrideKeys of+    [] -> pure ()+    unknownKeys ->+      fail . intercalate "\n" $+        [ "deriveEventCodecSkeleton: kindOverrides key "+            <> show key+            <> " is not a constructor of "+            <> nameBase tyName+            <> "."+        | key <- unknownKeys+        ]++  case duplicateWireKinds of+    [] -> pure ()+    duplicates ->+      fail . intercalate "\n" $+        [ "deriveEventCodecSkeleton: wire kind "+            <> show wireKind+            <> " is claimed by more than one constructor: "+            <> intercalate ", " owners+            <> ". Wire kinds must be unique per event type."+        | (wireKind, owners) <- duplicates+        ]++  case discriminatorCollisions of+    [] -> pure ()+    collisions ->+      fail . intercalate "\n" $+        [ "deriveEventCodecSkeleton: payload field "+            <> nameBase ctorName+            <> "."+            <> fieldName+            <> " collides with kindFieldName "+            <> show (kindFieldName opts)+            <> "; rename the field or choose a kindFieldName no payload uses."+        | (ctorName, fieldName) <- collisions+        ]+  where+    ctorBaseNames = map (nameBase . ecCtorName) ctors+    knownConstructors = Set.fromList ctorBaseNames+    unknownOverrideKeys =+      Set.toList (Map.keysSet (kindOverrides opts) `Set.difference` knownConstructors)+    wireKindOwners =+      Map.fromListWith+        (flip (<>))+        [ (wireKindOf opts (ecCtorName ec), [nameBase (ecCtorName ec)])+        | ec <- ctors+        ]+    duplicateWireKinds =+      [ (wireKind, owners)+      | (wireKind, owners) <- Map.toList wireKindOwners,+        length owners > 1+      ]+    discriminatorCollisions =+      [ (ecCtorName ec, fieldName)+      | ec <- ctors,+        (_, fields) <- maybe [] (: []) (ecPayload ec),+        (fieldName, _, _) <- fields,+        fieldName == kindFieldName opts+      ]++validateVersionEnvelope :: EventCodecOptions -> [EvCtor] -> Q ()+validateVersionEnvelope opts ctors = do+  if currentVersion opts < 1+    then+      fail $+        "deriveEventCodecSkeleton: currentVersion must be >= 1, got "+          <> show (currentVersion opts)+          <> "."+    else pure ()++  if kindFieldName opts == versionFieldName opts+    then+      fail $+        "deriveEventCodecSkeleton: kindFieldName "+          <> show (kindFieldName opts)+          <> " collides with versionFieldName "+          <> show (versionFieldName opts)+          <> "; choose distinct envelope keys."+    else pure ()++  case versionCollisions of+    [] -> pure ()+    collisions ->+      fail . intercalate "\n" $+        [ "deriveEventCodecSkeleton: payload field "+            <> nameBase ctorName+            <> "."+            <> fieldName+            <> " collides with versionFieldName "+            <> show (versionFieldName opts)+            <> "; rename the field or choose a versionFieldName no payload uses."+        | (ctorName, fieldName) <- collisions+        ]+  where+    versionCollisions =+      [ (ecCtorName ec, fieldName)+      | ec <- ctors,+        (_, fields) <- maybe [] (: []) (ecPayload ec),+        (fieldName, _, _) <- fields,+        fieldName == versionFieldName opts+      ]++validateUpcasters :: EventCodecOptions -> Q ()+validateUpcasters opts = do+  case duplicateSources of+    [] -> pure ()+    duplicates ->+      fail $+        "deriveEventCodecSkeleton: duplicate upcaster from-versions: "+          <> show duplicates++  case outOfRangeSources of+    [] -> pure ()+    invalidSources ->+      fail $+        "deriveEventCodecSkeleton: upcaster from-versions must be >= 1 and < currentVersion "+          <> show (currentVersion opts)+          <> "; out of range: "+          <> show invalidSources++  case missingSources of+    [] -> pure ()+    missing ->+      fail $+        "deriveEventCodecSkeleton: upcasters must cover from-versions [1.."+          <> show (currentVersion opts - 1)+          <> "] exactly; missing: "+          <> show missing+  where+    sources = map fst (upcasters opts)+    expectedSources = [1 .. currentVersion opts - 1]+    duplicateSources =+      [ source+      | source : _ : _ <- group (sort sources)+      ]+    outOfRangeSources =+      [ source+      | source <- sort sources,+        source < 1 || source >= currentVersion opts+      ]+    missingSources = expectedSources \\ sources  -- * Reflection --------------------------------------------------------------- 

@@ -1,35 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} --- \$('deriveRegFileCodec' \'\'MySnapshot)--- @------ to emit three top-level functions------ @--- mySnapshotToJSON     :: MySnapshot -> Aeson.Value--- mySnapshotToEncoding :: MySnapshot -> Aeson.Encoding--- mySnapshotFromJSON   :: Aeson.Value -> Either String MySnapshot--- @------ Each function routes through the existing--- 'Keiki.Codec.JSON.RegFileToJSON' class against the slot list--- @'Keiki.Generics.RegFieldsOf' MySnapshot@. The record's field names--- become the JSON object's keys; the record's field types must each--- carry 'Aeson.ToJSON' and 'Aeson.FromJSON' or compilation fails with a--- precise per-field error.------ This splice lives in @keiki-codec-json@ (not in @keiki@'s--- @Keiki.Generics.TH@). The class @RegFileToJSON@ is defined here, and--- moving the splice to @keiki@ would force an @aeson@ dependency on--- @keiki@ core — violating the load-bearing--- /keiki MUST NOT gain @aeson@/ requirement (EP-36 §3 R8; MP-11--- Decision Log 2026-05-10). The splice does reuse the structural--- machinery in @keiki@'s @Keiki.Generics@ ('Keiki.Generics.RegFieldsOf',--- 'Keiki.Generics.gToRegFile', 'Keiki.Generics.gFromRegFile') so the--- composition with the existing 'Keiki.Generics.TH' ergonomics--- (@mkInCtorVia@, @mkWireCtorVia@, @deriveAggregateCtors@, etc.) is--- preserved.- -- | -- Module      : Keiki.Codec.JSON.TH -- Description : Template Haskell helpers that emit @RegFile@-routed JSON@@ -43,12 +13,34 @@ --   , correlationId :: Text --   , dispatchedAt  :: UTCTime --   }---   deriving stock ('Eq', 'Show', GHC.Generics.'GHC.Generics.Generic')+--   deriving stock (Eq, Show, Generic) -- @ -- -- invokes -- -- @+-- \$('deriveRegFileCodec' \'\'MySnapshot)+--+-- mySnapshotToJSON     :: MySnapshot -> Aeson.Value+-- mySnapshotToEncoding :: MySnapshot -> Aeson.Encoding+-- mySnapshotFromJSON   :: Aeson.Value -> Either String MySnapshot+-- @+--+-- to emit those three top-level functions. Each function routes through the+-- existing 'Keiki.Codec.JSON.RegFileToJSON' class against the slot list+-- @'Keiki.Generics.RegFieldsOf' MySnapshot@. The record's field names become+-- the JSON object's keys; the record's field types must each carry+-- 'Aeson.ToJSON' and 'Aeson.FromJSON' or compilation fails with a precise+-- per-field error.+--+-- This splice lives in @keiki-codec-json@ (not in @keiki@'s+-- @Keiki.Generics.TH@). The class @RegFileToJSON@ is defined here, and moving+-- the splice to @keiki@ would force an @aeson@ dependency on @keiki@ core —+-- violating the load-bearing /keiki MUST NOT gain @aeson@/ requirement (EP-36+-- §3 R8; MP-11 Decision Log 2026-05-10). The splice does reuse the structural+-- machinery in @keiki@'s @Keiki.Generics@ ('Keiki.Generics.RegFieldsOf',+-- 'Keiki.Generics.gToRegFile', 'Keiki.Generics.gFromRegFile') so composition+-- with the existing 'Keiki.Generics.TH' ergonomics is preserved. module Keiki.Codec.JSON.TH   ( deriveRegFileCodec,     deriveRegFileCodecAs,

@@ -8,6 +8,10 @@   ( -- * Baseline slot list     ExemplarSlots, +    -- * Maybe wire-semantics slot lists+    MaybeSlots,+    NestedMaybeSlots,+     -- * Schema-evolution mutations (EP-36 §4 cases #1–9)     AddSlots,     RemoveSlots,@@ -26,6 +30,9 @@      -- * Arbitrary generator     ArbitraryRegFile (..),++    -- * Value equality+    EqRegFile (..),   ) where @@ -53,6 +60,17 @@      '("correlationId", Text)    ] +-- | Optional fields whose absent values are encoded as explicit JSON @null@.+type MaybeSlots =+  '[ '("lastError", Maybe Text),+     '("approvedAt", Maybe UTCTime),+     '("shippingAddress", Maybe Address)+   ]++-- | A deliberately lossy aeson shape: @Just Nothing@ and @Nothing@ both+-- encode as JSON @null@.+type NestedMaybeSlots = '[ '("nested", Maybe (Maybe Int))]+ -- * Schema-evolution mutations (EP-36 §4) ------------------------------------  -- | §4 case #1 — Add slot. A fourth slot is appended to the baseline.@@ -186,3 +204,16 @@   ArbitraryRegFile ('(s, t) ': rs)   where   arbRegFile = RCons (Proxy @s) <$> arbitrary <*> arbRegFile++-- * Value equality for 'RegFile rs' -----------------------------------------++-- | Inductive heterogeneous equality. Each slot value is compared with its+-- own 'Eq' instance.+class EqRegFile (rs :: [Slot]) where+  eqRegFile :: RegFile rs -> RegFile rs -> Bool++instance EqRegFile '[] where+  eqRegFile _ _ = True++instance (Eq t, EqRegFile rs) => EqRegFile ('(s, t) ': rs) where+  eqRegFile (RCons _ x xs) (RCons _ y ys) = x == y && eqRegFile xs ys

@@ -0,0 +1,266 @@+-- | Checked-in persistence fixtures for whole register files and their shape.+--+-- Each register fixture is checked in both directions: current code decodes+-- historical bytes to a fixed heterogeneous value, and current encoding must+-- remain byte-identical. The Value and Encoding paths have separate files+-- because their object-key orders deliberately differ.+--+-- To regenerate only for an intentional wire-format change:+--+-- > KEIKI_UPDATE_GOLDENS=1 cabal test keiki-codec-json:keiki-codec-json-test+-- > cabal test keiki-codec-json:keiki-codec-json-test+-- > git diff keiki-codec-json/test/golden/+--+-- The first command rewrites the files and fails deliberately. The second must+-- be green after the environment variable is unset and the diff reviewed.+module Keiki.Codec.JSON.GoldenFileSpec (spec) where++import Data.Aeson qualified as Aeson+import Data.Aeson.Encoding qualified as AesonEnc+import Data.ByteString.Lazy qualified as LBS+import Data.Proxy (Proxy (..))+import Data.Text qualified as T+import Data.Time.Clock (UTCTime)+import Keiki.Codec.JSON (RegFileToJSON, regFileFromJSON, regFileToEncoding, regFileToJSON)+import Keiki.Codec.JSON.Fixtures+  ( Address (..),+    EqRegFile (eqRegFile),+    ExemplarSlots,+    MaybeSlots,+  )+import Keiki.Codec.JSON.THEventEvolutionSpec qualified as Evolution+import Keiki.Codec.JSON.THEventSpec qualified as Event+import Keiki.Core (RegFile (..))+import Keiki.Shape (regFileShapeCanonical, regFileShapeHash)+import System.Environment (lookupEnv)+import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe)++data EncoderPath = ValuePath | EncodingPath++spec :: Spec+spec = do+  describe "checked-in RegFile bytes" $ do+    regFileGoldenSpec+      "exemplar Value path"+      "test/golden/exemplar-regfile.value.json"+      ValuePath+      exemplarRegFile+    regFileGoldenSpec+      "exemplar Encoding path"+      "test/golden/exemplar-regfile.encoding.json"+      EncodingPath+      exemplarRegFile+    regFileGoldenSpec+      "all-Just Maybe slots, Value path"+      "test/golden/maybe-regfile-just.value.json"+      ValuePath+      maybeJustRegFile+    regFileGoldenSpec+      "all-Just Maybe slots, Encoding path"+      "test/golden/maybe-regfile-just.encoding.json"+      EncodingPath+      maybeJustRegFile+    regFileGoldenSpec+      "all-Nothing Maybe slots, Value path"+      "test/golden/maybe-regfile-nothing.value.json"+      ValuePath+      maybeNothingRegFile+    regFileGoldenSpec+      "all-Nothing Maybe slots, Encoding path"+      "test/golden/maybe-regfile-nothing.encoding.json"+      EncodingPath+      maybeNothingRegFile++  shapeGoldenSpec+  eventGoldenSpecs++regFileGoldenSpec ::+  forall rs.+  (RegFileToJSON rs, EqRegFile rs) =>+  String ->+  FilePath ->+  EncoderPath ->+  RegFile rs ->+  Spec+regFileGoldenSpec label path encoder expected = describe label $ do+  update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS")+  case update of+    Just _ -> do+      runIO (LBS.writeFile path currentBytes)+      it "regenerates and requires a clean review run" $+        expectationFailure regenerationMessage+    Nothing -> do+      historicalBytes <- runIO (LBS.readFile path)+      it "decodes checked-in bytes to the fixed value" $+        case Aeson.decode historicalBytes of+          Nothing -> expectationFailure "golden file is not valid JSON"+          Just value -> case regFileFromJSON @rs value of+            Left message -> expectationFailure ("golden decode failed: " <> message)+            Right actual -> eqRegFile actual expected `shouldBe` True+      it "freezes current encoder bytes" $+        currentBytes `shouldBe` historicalBytes+  where+    currentBytes = case encoder of+      ValuePath -> Aeson.encode (regFileToJSON expected)+      EncodingPath -> AesonEnc.encodingToLazyByteString (regFileToEncoding expected)++shapeGoldenSpec :: Spec+shapeGoldenSpec = describe "checked-in ExemplarSlots shape" $ do+  update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS")+  case update of+    Just _ -> do+      runIO (LBS.writeFile shapePath currentBytes)+      it "regenerates and requires a clean review run" $+        expectationFailure regenerationMessage+    Nothing -> do+      historicalBytes <- runIO (LBS.readFile shapePath)+      it "pins the canonical text and hash" $+        Aeson.decode historicalBytes `shouldBe` Just currentValue+      it "freezes the shape fixture bytes" $+        currentBytes `shouldBe` historicalBytes+  where+    shapePath = "test/golden/exemplar-shape.json"+    currentValue =+      Aeson.object+        [ "canonical" Aeson..= regFileShapeCanonical (Proxy @ExemplarSlots),+          "hash" Aeson..= regFileShapeHash (Proxy @ExemplarSlots)+        ]+    currentBytes = Aeson.encode currentValue++eventGoldenSpecs :: Spec+eventGoldenSpecs = describe "checked-in versioned event envelopes" $ do+  eventGoldenSpec+    "record payload with pinned kind and version"+    "test/golden/event/order-placed.v1.json"+    placedEvent+    Event.orderEventToJSON+    Event.orderEventFromJSON+  eventGoldenSpec+    "no-payload singleton with version"+    "test/golden/event/order-cancelled.v1.json"+    Event.Cancelled+    Event.orderEventToJSON+    Event.orderEventFromJSON+  eventGoldenSpec+    "current additive payload with explicit defaults"+    "test/golden/event/item-added.v1.json"+    additiveEvent+    Evolution.additiveEventToJSON+    Evolution.additiveEventFromJSON+  historicalEventGoldenSpec+    "pre-addition payload fills missing fields and absent version"+    "test/golden/event/item-added.pre-defaults.json"+    additiveEvent+    historicalAdditiveBytes+    Evolution.additiveEventFromJSON+  eventGoldenSpec+    "current structural payload after upcasting era"+    "test/golden/event/quantity-recorded.v2.json"+    structuralEvent+    Evolution.structuralEventToJSON+    Evolution.structuralEventFromJSON+  historicalEventGoldenSpec+    "version-1 payload runs the quantity upcaster"+    "test/golden/event/quantity-recorded.v1.json"+    structuralEvent+    historicalStructuralBytes+    Evolution.structuralEventFromJSON++eventGoldenSpec ::+  (Eq event, Show event) =>+  String ->+  FilePath ->+  event ->+  (event -> Aeson.Value) ->+  (Aeson.Value -> Either String event) ->+  Spec+eventGoldenSpec label path expected encoder decoder = describe label $ do+  update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS")+  case update of+    Just _ -> do+      runIO (LBS.writeFile path currentBytes)+      it "regenerates and requires a clean review run" $+        expectationFailure regenerationMessage+    Nothing -> do+      historicalBytes <- runIO (LBS.readFile path)+      it "decodes checked-in bytes to the fixed event" $+        case Aeson.eitherDecode historicalBytes of+          Left message -> expectationFailure ("golden file is not valid JSON: " <> message)+          Right value -> decoder value `shouldBe` Right expected+      it "freezes current event encoder bytes" $+        currentBytes `shouldBe` historicalBytes+  where+    currentBytes = Aeson.encode (encoder expected)++historicalEventGoldenSpec ::+  (Eq event, Show event) =>+  String ->+  FilePath ->+  event ->+  LBS.ByteString ->+  (Aeson.Value -> Either String event) ->+  Spec+historicalEventGoldenSpec label path expected frozenBytes decoder = describe label $ do+  update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS")+  case update of+    Just _ -> do+      runIO (LBS.writeFile path frozenBytes)+      it "regenerates and requires a clean review run" $+        expectationFailure regenerationMessage+    Nothing -> do+      historicalBytes <- runIO (LBS.readFile path)+      it "decodes the historical document to the current event" $+        case Aeson.eitherDecode historicalBytes of+          Left message -> expectationFailure ("golden file is not valid JSON: " <> message)+          Right value -> decoder value `shouldBe` Right expected+      it "freezes the historical document bytes" $+        historicalBytes `shouldBe` frozenBytes++exemplarRegFile :: RegFile ExemplarSlots+exemplarRegFile =+  RCons (Proxy @"retryCount") (3 :: Int) $+    RCons (Proxy @"cooldownUntil") exemplarTime $+      RCons (Proxy @"correlationId") (T.pack "order-123") RNil++maybeJustRegFile :: RegFile MaybeSlots+maybeJustRegFile =+  RCons (Proxy @"lastError") (Just (T.pack "address invalid")) $+    RCons (Proxy @"approvedAt") (Just exemplarTime) $+      RCons+        (Proxy @"shippingAddress")+        (Just (Address (T.pack "1 Main St") (T.pack "Portland") (T.pack "97201")))+        RNil++maybeNothingRegFile :: RegFile MaybeSlots+maybeNothingRegFile =+  RCons (Proxy @"lastError") Nothing $+    RCons (Proxy @"approvedAt") Nothing $+      RCons (Proxy @"shippingAddress") Nothing RNil++exemplarTime :: UTCTime+exemplarTime = read "2026-01-02 03:04:05 UTC"++placedEvent :: Event.OrderEvent+placedEvent = Event.Placed (Event.PlacedData (Event.OrderId 7) 3)++additiveEvent :: Evolution.AdditiveEvent+additiveEvent =+  Evolution.ItemAdded+    Evolution.ItemAddedData+      { Evolution.orderId = T.pack "ord-7",+        Evolution.discount = Evolution.Discount 0,+        Evolution.note = Nothing+      }++structuralEvent :: Evolution.StructuralEvent+structuralEvent = Evolution.QuantityRecorded (Evolution.QuantityRecordedData 3)++historicalAdditiveBytes :: LBS.ByteString+historicalAdditiveBytes = "{\"kind\":\"ItemAdded\",\"orderId\":\"ord-7\"}"++historicalStructuralBytes :: LBS.ByteString+historicalStructuralBytes = "{\"kind\":\"QuantityRecorded\",\"v\":1,\"qty\":3}"++regenerationMessage :: String+regenerationMessage =+  "golden regenerated; unset KEIKI_UPDATE_GOLDENS, re-run, and review git diff"

@@ -1,24 +1,22 @@ -- | EP-36 M3 golden hash file. ----- Pins the shape hash of 'ExemplarSlots' for the current GHC version.--- The cross-GHC CI gate (M5) compares this value across every GHC in--- @tested-with@; a divergence is a release-blocking bug per EP-36 §8.+-- Pins the canonical shape string and hash of 'ExemplarSlots'. Built-in+-- canonical names are module-independent, so these values are shared across+-- supported GHC versions. module Keiki.Codec.JSON.GoldenSpec (spec) where  import Data.Proxy (Proxy (..)) import Data.Text qualified as T import Keiki.Codec.JSON.Fixtures (ExemplarSlots)-import Keiki.Shape (regFileShapeHash)+import Keiki.Shape (regFileShapeCanonical, regFileShapeHash) import Test.Hspec (Spec, describe, it, shouldBe)  spec :: Spec spec = describe "Golden hash for ExemplarSlots" $ do-  -- This value is pinned for GHC 9.12.*. Drift here means either-  -- GHC's `tyConModule` / `tyConName` semantics changed for one of-  -- the slot types (Int / UTCTime / Text), or `renderStableTypeRep`-  -- inadvertently picked up a non-stable accessor. Per EP-36 §8 the-  -- release is blocked until the cause is understood; the fix may be a-  -- `CanonicalTypeName` override for the affected slot type.-  it "matches the pinned GHC-9.12.* value" $+  it "matches the pinned canonical string" $+    regFileShapeCanonical (Proxy @ExemplarSlots)+      `shouldBe` T.pack "retryCount:Int;cooldownUntil:UTCTime;correlationId:Text;regfile:0"++  it "matches the pinned GHC-independent value" $     regFileShapeHash (Proxy @ExemplarSlots)-      `shouldBe` T.pack "a37b2b77042a635f394a082765f3410ea23a0b89745b0c77242b925a03aa172b"+      `shouldBe` T.pack "d920c3660d5b2a7bda082cdedb08fa493acd3f74a663434a4cead475096866f9"

@@ -11,70 +11,117 @@  import Data.Aeson qualified as Aeson import Data.Aeson.Encoding qualified as AesonEnc-import Keiki.Codec.JSON (regFileFromJSON, regFileToEncoding, regFileToJSON)-import Keiki.Codec.JSON.Fixtures (ExemplarSlots, arbRegFile)+import Data.Proxy (Proxy (..))+import Keiki.Codec.JSON (RegFileToJSON, regFileFromJSON, regFileToEncoding, regFileToJSON)+import Keiki.Codec.JSON.Fixtures+  ( ArbitraryRegFile (arbRegFile),+    EqRegFile (eqRegFile),+    ExemplarSlots,+    MaybeSlots,+    NestedMaybeSlots,+  ) import Keiki.Core (RegFile)-import Test.Hspec (Spec, describe, it)+import Keiki.Core qualified as Core+import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck (Property, forAllShow, (===))  -- | RegFile rs has no Show instance (the slot list is heterogeneous); -- use the JSON encoding as the renderer for QuickCheck counterexamples.-showRegFile :: RegFile ExemplarSlots -> String+showRegFile :: (RegFileToJSON rs) => RegFile rs -> String showRegFile = show . regFileToJSON  spec :: Spec spec = do+  describe "ExemplarSlots" (codecProps @ExemplarSlots)+  describe "MaybeSlots" (codecProps @MaybeSlots)+  nestedMaybeSpec++codecProps ::+  forall rs.+  (RegFileToJSON rs, ArbitraryRegFile rs, EqRegFile rs) =>+  Spec+codecProps = do   describe "Roundtrip" $ do     it "Value path round-trips" $-      forAllShow arbRegFile showRegFile valueRoundTrip+      forAllShow (arbRegFile @rs) showRegFile (valueRoundTrip @rs)     it "Encoding path round-trips" $-      forAllShow arbRegFile showRegFile encodingRoundTrip+      forAllShow (arbRegFile @rs) showRegFile (encodingRoundTrip @rs)    describe "Determinism (R9 within-path)" $ do     it "Value path is deterministic" $-      forAllShow arbRegFile showRegFile valueDeterministic+      forAllShow (arbRegFile @rs) showRegFile valueDeterministic     it "Encoding path is deterministic" $-      forAllShow arbRegFile showRegFile encodingDeterministic+      forAllShow (arbRegFile @rs) showRegFile encodingDeterministic --- | @regFileFromJSON . regFileToJSON ≡ Right rf@. We use the encoded--- bytes as the canonical comparison point: re-encoding the parsed--- RegFile must yield the same bytes (proving structural equality--- without requiring a 'Eq' or 'Show' instance on 'RegFile').-valueRoundTrip :: RegFile ExemplarSlots -> Property+-- | @regFileFromJSON . regFileToJSON ≡ Right rf@. We compare decoded+-- slot values with the inductive 'EqRegFile' walker, so a lossy decode+-- cannot hide behind identical re-encoded bytes.+valueRoundTrip :: forall rs. (RegFileToJSON rs, EqRegFile rs) => RegFile rs -> Property valueRoundTrip rf =   let bytes = Aeson.encode (regFileToJSON rf)    in case Aeson.decode bytes of         Nothing ->           False === error "Aeson.decode failed on our own encoder output"-        Just v -> case regFileFromJSON @ExemplarSlots v of+        Just v -> case regFileFromJSON @rs v of           Left msg ->             False === error ("regFileFromJSON failed: " <> msg)-          Right rf' ->-            Aeson.encode (regFileToJSON rf') === bytes+          Right rf' -> eqRegFile rf' rf === True  -- | Encoding path round-trip via -- @regFileFromJSON . fromJust . Aeson.decode . AesonEnc.encodingToLazyByteString . regFileToEncoding@.-encodingRoundTrip :: RegFile ExemplarSlots -> Property+encodingRoundTrip :: forall rs. (RegFileToJSON rs, EqRegFile rs) => RegFile rs -> Property encodingRoundTrip rf =   let bytes = AesonEnc.encodingToLazyByteString (regFileToEncoding rf)    in case Aeson.decode bytes of         Nothing ->           False === error "Aeson.decode failed on streaming-encoder output"-        Just v -> case regFileFromJSON @ExemplarSlots v of+        Just v -> case regFileFromJSON @rs v of           Left msg ->             False === error ("regFileFromJSON failed: " <> msg)-          Right rf' ->-            AesonEnc.encodingToLazyByteString (regFileToEncoding rf') === bytes+          Right rf' -> eqRegFile rf' rf === True  -- | Re-encoding the same RegFile via the Value path produces byte- -- equal output.-valueDeterministic :: RegFile ExemplarSlots -> Property+valueDeterministic :: (RegFileToJSON rs) => RegFile rs -> Property valueDeterministic rf =   Aeson.encode (regFileToJSON rf)     === Aeson.encode (regFileToJSON rf)  -- | Re-encoding via the Encoding path produces byte-equal output.-encodingDeterministic :: RegFile ExemplarSlots -> Property+encodingDeterministic :: (RegFileToJSON rs) => RegFile rs -> Property encodingDeterministic rf =   AesonEnc.encodingToLazyByteString (regFileToEncoding rf)     === AesonEnc.encodingToLazyByteString (regFileToEncoding rf)++nestedMaybeSpec :: Spec+nestedMaybeSpec = describe "Nested Maybe wire semantics" $ do+  it "encodes Just Nothing as null and decodes it as outer Nothing" $ do+    let rf = nestedRegFile (Just Nothing)+    regFileToJSON rf+      `shouldBe` Aeson.object ["nested" Aeson..= Aeson.Null]+    assertNestedDecode rf Nothing++  it "round-trips Just (Just 42)" $+    assertNestedDecode (nestedRegFile (Just (Just 42))) (Just (Just 42))++  it "round-trips Nothing" $+    assertNestedDecode (nestedRegFile Nothing) Nothing++  it "rejects an absent Maybe slot rather than treating it as Nothing" $+    case regFileFromJSON @MaybeSlots+      ( Aeson.object+          [ "approvedAt" Aeson..= Aeson.Null,+            "shippingAddress" Aeson..= Aeson.Null+          ]+      ) of+      Left message -> message `shouldBe` "lastError: missing slot"+      Right _ -> error "expected an absent-slot failure"++nestedRegFile :: Maybe (Maybe Int) -> RegFile NestedMaybeSlots+nestedRegFile value = Core.RCons (Proxy @"nested") value Core.RNil++assertNestedDecode :: RegFile NestedMaybeSlots -> Maybe (Maybe Int) -> IO ()+assertNestedDecode rf expected =+  case regFileFromJSON @NestedMaybeSlots (regFileToJSON rf) of+    Left message -> error ("nested Maybe decode failed: " <> message)+    Right (Core.RCons _ actual Core.RNil) -> actual `shouldBe` expected

@@ -0,0 +1,227 @@+{-# LANGUAGE TemplateHaskell #-}++-- | EP-77 evolution regressions for additive event fields.+module Keiki.Codec.JSON.THEventEvolutionSpec+  ( spec,+    Discount (..),+    ItemAddedData (..),+    AdditiveEvent (..),+    additiveEventToJSON,+    additiveEventFromJSON,+    QuantityRecordedData (..),+    StructuralEvent (..),+    structuralEventToJSON,+    structuralEventFromJSON,+  )+where++import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy (ByteString)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Codec.JSON.Event+  ( EventCodecOptions (..),+    FieldCodec (fcOnMissing),+    defaultEventCodecOptions,+    deriveEventCodecSkeleton,+    fieldCodec,+  )+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.QuickCheck+  ( Gen,+    Property,+    chooseInt,+    elements,+    forAllShow,+    listOf1,+    oneof,+    (===),+  )++newtype Discount = Discount Int+  deriving stock (Eq, Show)++discountToJSON :: Discount -> Aeson.Value+discountToJSON (Discount amount) = Aeson.toJSON amount++discountFromJSON :: Aeson.Value -> Either String Discount+discountFromJSON value = case Aeson.fromJSON value of+  Aeson.Success amount -> Right (Discount amount)+  Aeson.Error message -> Left message++missingDiscount :: Discount+missingDiscount = Discount 0++data ItemAddedData = ItemAddedData+  { orderId :: Text,+    discount :: Discount,+    note :: Maybe Text+  }+  deriving stock (Eq, Show)++data AdditiveEvent = ItemAdded ItemAddedData+  deriving stock (Eq, Show)++$( deriveEventCodecSkeleton+     defaultEventCodecOptions+       { fieldCodecOverrides =+           Map.fromList+             [ ( "discount",+                 (fieldCodec 'discountToJSON 'discountFromJSON)+                   { fcOnMissing = Just 'missingDiscount+                   }+               )+             ],+         passthroughFields = Set.fromList ["orderId", "note"]+       }+     ''AdditiveEvent+ )++data QuantityRecordedData = QuantityRecordedData+  { quantity :: Int+  }+  deriving stock (Eq, Show)++data StructuralEvent = QuantityRecorded QuantityRecordedData+  deriving stock (Eq, Show)++upcastQuantityV1 :: Aeson.Value -> Either String Aeson.Value+upcastQuantityV1 value = case value of+  Aeson.Object object -> case KeyMap.lookup (Key.fromString "qty") object of+    Nothing -> Left "missing qty"+    Just quantityValue ->+      Right+        ( Aeson.Object+            (KeyMap.insert (Key.fromString "quantity") quantityValue object)+        )+  _ -> Left "expected an object"++$( deriveEventCodecSkeleton+     defaultEventCodecOptions+       { passthroughFields = Set.fromList ["quantity"],+         currentVersion = 2,+         upcasters = [(1, 'upcastQuantityV1)]+       }+     ''StructuralEvent+ )++-- These bytes predate the note and discount fields; do not regenerate them.+oldAdditiveBytes :: ByteString+oldAdditiveBytes = "{\"kind\":\"ItemAdded\",\"orderId\":\"ord-7\"}"++decodeAdditiveBytes :: ByteString -> Either String AdditiveEvent+decodeAdditiveBytes bytes = do+  value <- Aeson.eitherDecode bytes+  additiveEventFromJSON value++decodeStructuralBytes :: ByteString -> Either String StructuralEvent+decodeStructuralBytes bytes = do+  value <- Aeson.eitherDecode bytes+  structuralEventFromJSON value++arbAdditiveEvent :: Gen AdditiveEvent+arbAdditiveEvent = do+  orderNumber <- chooseInt (0, 100000)+  discountAmount <- chooseInt (-1000, 1000)+  generatedNote <-+    oneof+      [ pure Nothing,+        Just . T.pack <$> listOf1 (elements ['a' .. 'z'])+      ]+  pure+    ( ItemAdded+        ItemAddedData+          { orderId = T.pack ("ord-" <> show orderNumber),+            discount = Discount discountAmount,+            note = generatedNote+          }+    )++roundTripProperty :: AdditiveEvent -> Property+roundTripProperty event =+  additiveEventFromJSON (additiveEventToJSON event) === Right event++spec :: Spec+spec = describe "default-on-missing event fields" $ do+  it "exports the additive fixture's wire metadata" $ do+    additiveEventSchemaVersion `shouldBe` 1+    additiveEventEventTypes `shouldBe` [T.pack "ItemAdded"]+    additiveEventKindMap+      `shouldBe` [(T.pack "ItemAdded", T.pack "ItemAdded")]++  it "decodes bytes written before the additive fields existed" $+    decodeAdditiveBytes oldAdditiveBytes+      `shouldBe` Right+        ( ItemAdded+            ItemAddedData+              { orderId = T.pack "ord-7",+                discount = missingDiscount,+                note = Nothing+              }+        )++  it "decodes a present null Maybe field as Nothing" $+    decodeAdditiveBytes+      "{\"kind\":\"ItemAdded\",\"orderId\":\"ord-7\",\"discount\":12,\"note\":null}"+      `shouldBe` Right+        ( ItemAdded+            ItemAddedData+              { orderId = T.pack "ord-7",+                discount = Discount 12,+                note = Nothing+              }+        )++  it "round-trips a fully populated value" $+    let event =+          ItemAdded+            ItemAddedData+              { orderId = T.pack "ord-8",+                discount = Discount 15,+                note = Just (T.pack "priority")+              }+     in additiveEventFromJSON (additiveEventToJSON event) `shouldBe` Right event++  it "round-trips generated Nothing and Just values" $+    forAllShow arbAdditiveEvent show roundTripProperty++  it "keeps required fields strict" $+    decodeAdditiveBytes "{\"kind\":\"ItemAdded\"}"+      `shouldBe` (Left "missing field: orderId" :: Either String AdditiveEvent)++  describe "upcaster chain" $ do+    let expected = QuantityRecorded (QuantityRecordedData 3)++    it "exports the structural fixture's current wire metadata" $ do+      structuralEventSchemaVersion `shouldBe` 2+      structuralEventEventTypes `shouldBe` [T.pack "QuantityRecorded"]+      structuralEventKindMap+        `shouldBe` [(T.pack "QuantityRecorded", T.pack "QuantityRecorded")]++    it "decodes version-1 bytes after renaming qty to quantity" $+      decodeStructuralBytes+        "{\"kind\":\"QuantityRecorded\",\"v\":1,\"qty\":3}"+        `shouldBe` Right expected++    it "runs the version-1 upcaster for an absent version stamp" $+      decodeStructuralBytes+        "{\"kind\":\"QuantityRecorded\",\"qty\":3}"+        `shouldBe` Right expected++    it "decodes current-version bytes without running an old rung" $ do+      decodeStructuralBytes+        "{\"kind\":\"QuantityRecorded\",\"v\":2,\"quantity\":3}"+        `shouldBe` Right expected+      structuralEventFromJSON (structuralEventToJSON expected)+        `shouldBe` Right expected++    it "surfaces a rung failure with its source version" $+      decodeStructuralBytes+        "{\"kind\":\"QuantityRecorded\",\"v\":1}"+        `shouldBe` ( Left "upcaster from version 1: missing qty" ::+                       Either String StructuralEvent+                   )

@@ -45,9 +45,52 @@ --    @_todo_Placed_discount@ in @cabal repl@ shows the binding exists. --    Revert afterwards. ----- Both behaviours were verified by hand on 2026-06-06; the observed--- compile-fail text matched (1) verbatim.-module Keiki.Codec.JSON.THEventSpec (spec) where+-- 3. Duplicate wire kinds. Add+--    @kindOverrides = Map.fromList [("Placed", "order.event"),+--    ("Shipped", "order.event")]@, build the test target, and expect:+--+--    @+--    deriveEventCodecSkeleton: wire kind "order.event" is claimed by more+--    than one constructor: Placed, Shipped. Wire kinds must be unique per+--    event type.+--    @+--+--    Revert the override.+--+-- 4. Discriminator collision. Add @kind :: Text@ to @PlacedData@ and list+--    @"kind"@ in 'passthroughFields', build the test target, and expect:+--+--    @+--    deriveEventCodecSkeleton: payload field Placed.kind collides with+--    kindFieldName "kind"; rename the field or choose a kindFieldName no+--    payload uses.+--    @+--+--    Revert the field and passthrough entry.+--+-- 5. Incomplete upcaster chain. In @THEventEvolutionSpec@, set the+--    @StructuralEvent@ codec's @currentVersion = 3@ while retaining only+--    @upcasters = [(1, 'upcastQuantityV1)]@. Build the test target and expect:+--+--    @+--    deriveEventCodecSkeleton: upcasters must cover from-versions [1..2]+--    exactly; missing: [2]+--    @+--+--    Restore @currentVersion = 2@.+--+-- Checks (1) and (2) were verified by hand on 2026-06-06; the observed+-- compile-fail text matched (1) verbatim. Checks (3), (4), and (5) were+-- verified by hand on 2026-07-12 with the messages above.+module Keiki.Codec.JSON.THEventSpec+  ( spec,+    OrderId (..),+    PlacedData (..),+    OrderEvent (..),+    orderEventToJSON,+    orderEventFromJSON,+  )+where  import Data.Aeson qualified as Aeson import Data.Map.Strict qualified as Map@@ -56,9 +99,9 @@ import Data.Text qualified as T import Keiki.Codec.JSON.Event   ( EventCodecOptions (..),-    FieldCodec (..),     defaultEventCodecOptions,     deriveEventCodecSkeleton,+    fieldCodec,   ) import Test.Hspec (Spec, describe, it, shouldBe) import Text.Read (readMaybe)@@ -101,8 +144,9 @@ $( deriveEventCodecSkeleton      defaultEventCodecOptions        { fieldCodecOverrides =-           Map.fromList [("orderId", FieldCodec 'orderIdToJSON 'orderIdFromJSON)],-         passthroughFields = Set.fromList ["qty", "trackingNo"]+           Map.fromList [("orderId", fieldCodec 'orderIdToJSON 'orderIdFromJSON)],+         passthroughFields = Set.fromList ["qty", "trackingNo"],+         kindOverrides = Map.fromList [("Placed", "order.placed")]        }      ''OrderEvent  )@@ -127,48 +171,100 @@    describe "kind discriminator + override usage" $ do     -- orderEventToJSON (Placed (PlacedData (OrderId 7) 3))-    -- == {"kind":"Placed","orderId":"ord-7","qty":3}+    -- == {"kind":"order.placed","v":1,"orderId":"ord-7","qty":3}     it "Placed carries the kind key, the override output, and the passthrough field" $       orderEventToJSON placed         `shouldBe` Aeson.object-          [ "kind" Aeson..= (T.pack "Placed" :: Text),+          [ "kind" Aeson..= (T.pack "order.placed" :: Text),+            "v" Aeson..= (1 :: Int),             "orderId" Aeson..= (T.pack "ord-7" :: Text),             "qty" Aeson..= (3 :: Int)           ] -    it "the orderId override ran (string \"ord-7\", not the integer 7)" $+    it "a pinned wire kind decodes independently of the Haskell constructor name" $       -- If a generic Int codec had been silently used, this would be 7.       orderEventFromJSON         ( Aeson.object-            [ "kind" Aeson..= (T.pack "Placed" :: Text),+            [ "kind" Aeson..= (T.pack "order.placed" :: Text),               "orderId" Aeson..= (T.pack "ord-7" :: Text),               "qty" Aeson..= (3 :: Int)             ]         )         `shouldBe` Right placed -    it "Cancelled encodes to just the kind object" $+    it "Cancelled encodes to just the envelope keys" $       orderEventToJSON cancelled-        `shouldBe` Aeson.object ["kind" Aeson..= (T.pack "Cancelled" :: Text)]+        `shouldBe` Aeson.object+          [ "kind" Aeson..= (T.pack "Cancelled" :: Text),+            "v" Aeson..= (1 :: Int)+          ] +  describe "schema version envelope" $ do+    it "exports the current schema version" $+      orderEventSchemaVersion `shouldBe` 1++    it "treats a missing version key as version 1" $+      orderEventFromJSON+        ( Aeson.object+            [ "kind" Aeson..= (T.pack "order.placed" :: Text),+              "orderId" Aeson..= (T.pack "ord-7" :: Text),+              "qty" Aeson..= (3 :: Int)+            ]+        )+        `shouldBe` Right placed++    it "rejects an event written by a newer codec" $+      orderEventFromJSON+        ( Aeson.object+            [ "kind" Aeson..= (T.pack "Cancelled" :: Text),+              "v" Aeson..= (2 :: Int)+            ]+        )+        `shouldBe` ( Left "event schema version 2 is ahead of codec version 1" ::+                       Either String OrderEvent+                   )++    it "rejects a schema version below 1" $+      orderEventFromJSON+        ( Aeson.object+            [ "kind" Aeson..= (T.pack "Cancelled" :: Text),+              "v" Aeson..= (0 :: Int)+            ]+        )+        `shouldBe` (Left "invalid event schema version: 0" :: Either String OrderEvent)++    it "rejects a non-integral schema-version value" $+      orderEventFromJSON+        ( Aeson.object+            [ "kind" Aeson..= (T.pack "Cancelled" :: Text),+              "v" Aeson..= (T.pack "one" :: Text)+            ]+        )+        `shouldBe` ( Left "field v: expected an integer schema version" ::+                       Either String OrderEvent+                   )+   describe "decoder error paths" $ do     it "an unknown kind is reported" $       orderEventFromJSON         (Aeson.object ["kind" Aeson..= (T.pack "Nope" :: Text)])-        `shouldBe` (Left "unknown event kind: Nope" :: Either String OrderEvent)+        `shouldBe` ( Left+                       "unknown event kind: Nope (expected one of: order.placed, Shipped, Cancelled)" ::+                       Either String OrderEvent+                   )      it "a non-object is reported" $       orderEventFromJSON (Aeson.toJSON (5 :: Int))         `shouldBe` (Left "orderEvent: expected a JSON object" :: Either String OrderEvent)    describe "Keiro-feeding surfaces" $ do-    it "EventTypes lists the constructors in declaration order" $+    it "EventTypes lists resolved wire kinds in declaration order" $       orderEventEventTypes-        `shouldBe` map T.pack ["Placed", "Shipped", "Cancelled"]+        `shouldBe` map T.pack ["order.placed", "Shipped", "Cancelled"]      it "KindMap pairs each constructor name with its kind string" $       orderEventKindMap-        `shouldBe` [ (T.pack "Placed", T.pack "Placed"),+        `shouldBe` [ (T.pack "Placed", T.pack "order.placed"),                      (T.pack "Shipped", T.pack "Shipped"),                      (T.pack "Cancelled", T.pack "Cancelled")                    ]

@@ -7,28 +7,34 @@ -- on missing slot, extra slot, type mismatch. module Main (main) where +import Control.Exception (ErrorCall (..), evaluate) import Data.Aeson qualified as Aeson import Data.Aeson.Encoding qualified as AesonEnc import Data.ByteString.Lazy qualified as LBS import Data.Kind (Type)+import Data.List (isPrefixOf) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Text (Text) import Data.Text qualified as T import GHC.TypeLits (Symbol) import Keiki.Codec.JSON (regFileFromJSON, regFileToEncoding, regFileToJSON)+import Keiki.Codec.JSON.GoldenFileSpec qualified import Keiki.Codec.JSON.GoldenSpec qualified import Keiki.Codec.JSON.PropSpec qualified import Keiki.Codec.JSON.SensitivitySpec qualified+import Keiki.Codec.JSON.THEventEvolutionSpec qualified import Keiki.Codec.JSON.THEventSpec qualified import Keiki.Codec.JSON.THSpec qualified import Keiki.Core (RegFile (..))+import Keiki.Generics (emptyRegFile) import Test.Hspec   ( Spec,     describe,     hspec,     it,     shouldBe,+    shouldThrow,   )  main :: IO ()@@ -37,8 +43,10 @@   describe "M3 properties" Keiki.Codec.JSON.PropSpec.spec   describe "M3 sensitivity" Keiki.Codec.JSON.SensitivitySpec.spec   describe "M3 golden hash" Keiki.Codec.JSON.GoldenSpec.spec+  describe "EP-78 checked-in persistence goldens" Keiki.Codec.JSON.GoldenFileSpec.spec   describe "EP-38 deriveRegFileCodec" Keiki.Codec.JSON.THSpec.spec   describe "EP-59 deriveEventCodecSkeleton" Keiki.Codec.JSON.THEventSpec.spec+  describe "EP-77 event schema evolution" Keiki.Codec.JSON.THEventEvolutionSpec.spec  spec :: Spec spec = do@@ -112,6 +120,13 @@                   ]               )       isExtraFieldsLeft r `shouldBe` True++    it "throws a slot-named error when encoding an unwritten slot" $ do+      let uninitialized =+            emptyRegFile :: RegFile '[ '("retryCount", Int)]+      evaluate (LBS.length (Aeson.encode (regFileToJSON uninitialized)))+        `shouldThrow` \(ErrorCall message) ->+          "uninit: retryCount" `isPrefixOf` message    describe "Multi-slot RegFile (Int + Text)" $ do     let rf :: RegFile '[ '("retryCount", Int), '("note", Text)]

@@ -0,0 +1,1 @@+{"kind":"ItemAdded","orderId":"ord-7"}

@@ -0,0 +1,1 @@+{"discount":0,"kind":"ItemAdded","note":null,"orderId":"ord-7","v":1}

@@ -0,0 +1,1 @@+{"kind":"Cancelled","v":1}

@@ -0,0 +1,1 @@+{"kind":"order.placed","orderId":"ord-7","qty":3,"v":1}

@@ -0,0 +1,1 @@+{"kind":"QuantityRecorded","v":1,"qty":3}

@@ -0,0 +1,1 @@+{"kind":"QuantityRecorded","quantity":3,"v":2}

@@ -0,0 +1,1 @@+{"retryCount":3,"cooldownUntil":"2026-01-02T03:04:05Z","correlationId":"order-123"}

@@ -0,0 +1,1 @@+{"cooldownUntil":"2026-01-02T03:04:05Z","correlationId":"order-123","retryCount":3}

@@ -0,0 +1,1 @@+{"canonical":"retryCount:Int;cooldownUntil:UTCTime;correlationId:Text;regfile:0","hash":"d920c3660d5b2a7bda082cdedb08fa493acd3f74a663434a4cead475096866f9"}

@@ -0,0 +1,1 @@+{"lastError":"address invalid","approvedAt":"2026-01-02T03:04:05Z","shippingAddress":{"city":"Portland","line":"1 Main St","postcode":"97201"}}

@@ -0,0 +1,1 @@+{"approvedAt":"2026-01-02T03:04:05Z","lastError":"address invalid","shippingAddress":{"city":"Portland","line":"1 Main St","postcode":"97201"}}

@@ -0,0 +1,1 @@+{"lastError":null,"approvedAt":null,"shippingAddress":null}

@@ -0,0 +1,1 @@+{"approvedAt":null,"lastError":null,"shippingAddress":null}