diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,50 @@ +# Changelog + +All notable changes to this package are documented in this file. +The format follows [Keep a Changelog](https://keepachangelog.com/), +and this project adheres to the +[Haskell PVP](https://pvp.haskell.org). + + +## [Unreleased] + + +## [0.1.0.0] — 2026-06-07 + +Initial Hackage release. Co-released with `keiki-0.1.0.0`; this +package depends on `keiki ^>= 0.1`. + +### Added + +- `Keiki.Codec.JSON` — three-method codec class `RegFileToJSON + (rs :: [Slot])`: + - `regFileToJSON :: RegFile rs -> Aeson.Value` (strict Value-path encoder). + - `regFileFromJSON :: Aeson.Value -> Either String (RegFile rs)` + (strict decoder; rejects missing / extra / type-mismatched + fields with per-slot error messages). + - `regFileToEncoding :: RegFile rs -> Aeson.Encoding` (streaming + encoder over `Aeson.Series` that avoids the O(output-size) + intermediate `Aeson.Value` allocation). + - A single auto-derived instance for every slot list whose slot + types have `Aeson.ToJSON` + `Aeson.FromJSON`; users do not + write instances by hand. +- `Keiki.Codec.JSON.TH` — Template Haskell helpers + `deriveRegFileCodec` and `deriveRegFileCodecAs` that emit + three top-level codec functions (`ToJSON`, + `ToEncoding`, `FromJSON`) for a record type + with `deriving (Generic)`. + +### Validated against + +- GHC 9.12.2 locally on macOS aarch64 and in CI on Ubuntu Linux + x86_64 (see `.github/workflows/ci.yml`). +- 40 hspec assertions, including 4 QuickCheck properties (100 + samples each), 9 schema-evolution sensitivity assertions + (EP-36 §4 cases #1–9), a pinned golden shape hash, and 10 + `Keiki.Codec.JSON.TH` derivation tests. +- A `tasty-bench` baseline (`bench/baseline.csv`) for four + representative `RegFile` size scenarios (multi-party signing, + batch reconciliation, ticket aggregate, auction); the + Encoding-path is ~1.5× faster than the Value-path on the + streaming-motivating case (5,000-entry list) with 33 % less + allocation. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,76 @@ +# Contributing to keiki-codec-json + +## GHC upgrade procedure (release-blocking) + +The shape hash that powers snapshot discrimination +(`Keiki.Shape.regFileShapeHash`) uses `tyConModule + tyConName + +splitApps` from `Type.Reflection`. These accessors are stable across +GHC patch and minor versions historically, but the contract is not +covenanted forever. When bumping `tested-with` in `keiki.cabal`: + +1. Add the new GHC to CI (`.github/workflows/ci.yml`'s `ghc` matrix + entry). +2. Run the cross-GHC golden hash test: + + cabal test keiki-codec-json:keiki-codec-json-test \ + --test-options="--match 'M3 golden hash'" + + This asserts `regFileShapeHash (Proxy @ExemplarSlots)` matches the + pinned value + `a37b2b77042a635f394a082765f3410ea23a0b89745b0c77242b925a03aa172b`. + +3. **If the test fails: stop. Block the release.** The cause is one of: + - The new GHC changed `tyConModule` / `tyConName` semantics for one + of the slot types (`Int` / `UTCTime` / `Text`). File an upstream + GHC bug AND ship a `CanonicalTypeName` migration path for affected + users (override the canonical name to the old value via + `instance CanonicalTypeName Int where canonicalTypeName _ = "GHC.Types.Int"`, + and bump the package's major version because the hash that + in-flight snapshots carry is no longer derivable). + - `renderStableTypeRep` has acquired an unintentional dependency on + a non-stable accessor. Fix the keiki-side code; the hash for any + stably-named type must continue to match the pinned golden. + +4. Update `tested-with` in `keiki.cabal` (and `keiki-codec-json.cabal` + for symmetry). + +5. Add a release note explicitly flagging GHC X.Y.Z as validated + against the golden hash. + +The cross-GHC golden hash test is a **release-blocking gate**, not a +guideline. The whole point of the design is that drift cannot occur +silently; treating the test as advisory defeats the design (see EP-36 +§8 in `docs/plans/36-regfile-json-codec-and-shape-hash-for-snapshot-persistence.md`). + +## Performance bench drift + +`bench/baseline.csv` is committed alongside the source. CI runs the +bench on every PR but does NOT block merges on drift. Reviewers should +look at the bench job output for unexpected slowdowns; > 20 % drift on +any single fixture × path pair is worth a comment. The GHC-9.12 golden +hash gate is the release blocker, not the bench, because (a) bench +numbers are noisier than hash determinism, and (b) the meaningful unit +of latency budget belongs to the consumer (keiro), not to keiki itself. + +## Releasing + +The full release procedure lives at +[`../docs/research/release-procedure.md`](../docs/research/release-procedure.md). +That document covers the coordinated push of `keiki`, +`keiki-codec-json`, and `keiki-codec-json-test`, the pre-publish +checklist, and the candidate-upload runbook. The EP-37 ExecPlan at +[`../docs/plans/37-coordinated-hackage-release-of-keiki-and-keiki-codec-json-v0-1.md`](../docs/plans/37-coordinated-hackage-release-of-keiki-and-keiki-codec-json-v0-1.md) +is the per-milestone narrative for the v0.1 first release. + +## Adding a slot type to the test fixtures + +If you add a new slot type to `Keiki.Codec.JSON.Fixtures.ExemplarSlots`, +the golden hash will change. Steps: + +1. Update the fixture in `keiki-codec-json/test/Keiki/Codec/JSON/Fixtures.hs`. +2. Run `cabal test keiki-codec-json:keiki-codec-json-test`; capture the + reported new hash from `GoldenSpec.hs`. +3. Update `keiki-codec-json/test/Keiki/Codec/JSON/GoldenSpec.hs` with the + new pinned value. +4. Note the fixture change in the commit message; the cross-GHC gate's + new baseline is implicitly established. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,228 @@ +# keiki-codec-json + +Optional JSON codec support for +[`keiki`](https://hackage.haskell.org/package/keiki)'s type-level +register file, `RegFile rs`. + +This package is separate by design: the `keiki` core remains +`aeson`-free, while applications that persist snapshots as JSON can opt +in here. The structural shape hash +(`Keiki.Shape.regFileShapeHash`) stays in `keiki` so consumers can +discriminate snapshot shapes without pulling in a JSON dependency. + +This package ships: + +- `Keiki.Codec.JSON.RegFileToJSON` — three-method class providing + - `regFileToJSON :: RegFile rs -> Aeson.Value` (strict object encoder) + - `regFileFromJSON :: Aeson.Value -> Either String (RegFile rs)` + (strict decoder; missing / extra / type-mismatched fields are + rejected with a per-slot error message) + - `regFileToEncoding :: RegFile rs -> Aeson.Encoding` — streaming + encoder over `Aeson.Series`, avoiding the O(output-size) + intermediate `Aeson.Value` allocation for users with multi-MB slot + values +- `Keiki.Codec.JSON.TH` — Template Haskell helpers for deriving record + codecs through the same `RegFileToJSON` path +- `Keiki.Codec.JSON.Event` — Template Haskell helpers for generating a + `kind`-discriminated event codec skeleton from event sum types + +## Using + +```haskell +import Data.Proxy (Proxy (..)) +import Keiki.Codec.JSON (regFileFromJSON, regFileToEncoding, regFileToJSON) +import Keiki.Shape (regFileShapeHash) + +type Snapshot = '[ '("retryCount", Int), '("note", Text) ] + +-- Snapshot persister: +let bytes = encodingToLazyByteString (regFileToEncoding rf) + hash = regFileShapeHash (Proxy @Snapshot) +writeRow (snapshotTable hash bytes) + +-- Hydration: +case Aeson.decode bytes of + Nothing -> Left "snapshot bytes not JSON" + Just v -> regFileFromJSON @Snapshot v +``` + +## Deriving the codec for a record type + +If you have a plain Haskell record and want the three codec functions +without writing them by hand, use the TH splice from +`Keiki.Codec.JSON.TH`: + +```haskell +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +import qualified Data.Aeson as Aeson +import Data.Text (Text) +import GHC.Generics (Generic) +import Keiki.Codec.JSON.TH (deriveRegFileCodec) + +data Snapshot = Snapshot + { retryCount :: Int + , note :: Text + } + deriving stock (Eq, Show, Generic) + +$(deriveRegFileCodec ''Snapshot) +-- emits: +-- snapshotToJSON :: Snapshot -> Aeson.Value +-- snapshotToEncoding :: Snapshot -> Aeson.Encoding +-- snapshotFromJSON :: Aeson.Value -> Either String Snapshot +``` + +The emitted functions route through the same `RegFileToJSON` class as +the hand-written path: the record's field names become the JSON object's +keys, missing/extra/type-mismatched fields are rejected with the same +per-slot error messages, and the encoding path streams without +allocating an intermediate `Aeson.Value`. + +Every field type must carry `Aeson.ToJSON` + `Aeson.FromJSON`. If a +field type lacks either instance, compilation fails at the use site of +the emitted function with a precise per-field error pointing at the +missing instance. + +The record must have `deriving (Generic)` — the splice does not emit +a `Generic` instance for you. Multi-constructor sum types, positional +(non-record-syntax) constructors, and type synonyms are rejected at +splice time with a precise error message. + +## Deriving an event codec skeleton + +A service that stores its events as JSON usually hand-writes a +`kind`-discriminated encoder/decoder per event *sum* type — a large +`case` with one branch per constructor and one `.=` per payload field, +plus a matching parser. `deriveEventCodecSkeleton` (from +`Keiki.Codec.JSON.Event`) removes that boilerplate. Given a sum type whose +constructors each wrap a single record payload, or are no-argument +singletons: + +```haskell +{-# LANGUAGE TemplateHaskell #-} + +import qualified Data.Aeson as Aeson +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text (Text) +import Keiki.Codec.JSON.Event + ( EventCodecOptions (..) + , FieldCodec (..) + , defaultEventCodecOptions + , deriveEventCodecSkeleton + ) + +newtype OrderId = OrderId Int deriving stock (Eq, Show) +orderIdToJSON :: OrderId -> Aeson.Value +orderIdFromJSON :: Aeson.Value -> Either String OrderId + +data PlacedData = PlacedData + { orderId :: OrderId + , qty :: Int + } + deriving stock (Eq, Show) + +data ShippedData = ShippedData + { trackingNo :: Text + } + deriving stock (Eq, Show) + +data OrderEvent + = Placed PlacedData + | Shipped ShippedData + | Cancelled + deriving stock (Eq, Show) + +$(deriveEventCodecSkeleton + defaultEventCodecOptions + { fieldCodecOverrides = + Map.fromList [("orderId", FieldCodec 'orderIdToJSON 'orderIdFromJSON)] + , passthroughFields = Set.fromList ["qty", "trackingNo"] + } + ''OrderEvent) +-- emits, using the lower-cased type name as prefix: +-- orderEventToJSON :: OrderEvent -> Aeson.Value +-- orderEventFromJSON :: Aeson.Value -> Either String OrderEvent +-- orderEventEventTypes :: [Text] +-- orderEventKindMap :: [(Text, Text)] +``` + +Each constructor encodes to an object carrying a `"kind"` discriminator +(its constructor name) 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`. + +**No silent generic fallback.** Each payload field is encoded by *name*: +an override (`fieldCodecOverrides`), a passthrough using the field's own +aeson instances (`passthroughFields`), or — for a field in neither — +whatever `onMissingCodec` says. The default `FailAtCompileTime` aborts the +splice listing every unhandled `. :: `; the +alternative `EmitTodoBindings` emits a `_todo__` placeholder +that compiles but fails when evaluated. Adding a field to a payload +record therefore forces a compile-time decision instead of silently +changing, or dropping, the stored JSON. + +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`). + +## When to use the streaming encoder + +`regFileToJSON` builds an `Aeson.Value` whose `Object` is an +`Aeson.KeyMap` — internally a `Map Key Value` in aeson 2.2, so its +serialised form orders keys alphabetically. `regFileToEncoding` walks +the slot list directly into `Aeson.Series` (slot-list order) without +materialising the intermediate `Aeson.Value`. Both paths round-trip +through `regFileFromJSON` to the same `RegFile`, but for multi-MB +RegFiles the Encoding path saves a substantial allocation (see +`bench/baseline.csv` — for the 5000-item batch reconciliation fixture +the Encoding path is ~1.5× faster and allocates roughly two-thirds the +bytes). + +## Benchmarks + +```sh +cabal bench keiki-codec-json:keiki-codec-json-bench +``` + +Four fixtures cover representative snapshot sizes: + +| Fixture | Scenario | Condensed size | +|------------------------|--------------------------|--------------------------| +| `BenchA_ContractSign` | Contract signing | 5 parties, 50 audit rows | +| `BenchB_BatchRecon` | Batch reconciliation | 5,000 processedItems | +| `BenchC_TicketAgg` | Ticket aggregate | 100 comments | +| `BenchD_Auction` | Auction | 1,000 bids | + +Per fixture: `encode-via-Value`, `encode-via-Encoding`, `decode`, `hash`. + +`bench/baseline.csv` carries reference numbers from a GHC 9.12.2 run on +macOS aarch64. The benchmark is a tracked metric, not a correctness +gate; the golden shape-hash tests are the release-blocking checks. + +## Test toolkit for downstream consumers + +If you persist `RegFile rs` to JSON and want to guard against the +schema-evolution case the shape hash cannot catch by design — a +silent change to a slot type's `Aeson.ToJSON` instance — see the +sibling package +[`keiki-codec-json-test`](../keiki-codec-json-test/README.md). It +ships a per-slot-type golden-byte detector (`slotGoldenSpec`) plus +library versions of the round-trip and sensitivity disciplines, +parameterised over your own slot list. Production consumers of +`keiki-codec-json` do not need to depend on it. + +## Test suite + +```sh +cabal test keiki-codec-json:keiki-codec-json-test +``` + +Covers unit tests, four QuickCheck properties, schema-evolution +sensitivity assertions, and the golden hash fixture pinned for +GHC 9.12.*. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | EP-36 M4 — performance baselines for the four §10 reference cases +-- (condensed to keep CI bench duration under ~30 seconds total). +-- +-- For each fixture, four measurements: +-- +-- * @encode-via-Value@ — @Aeson.encode . regFileToJSON@ +-- * @encode-via-Encoding@ — @encodingToLazyByteString . regFileToEncoding@ +-- * @decode@ — @regFileFromJSON . fromJust . Aeson.decode@ +-- * @hash@ — @regFileShapeHash (Proxy \@SlotList)@ +-- +-- Run with @cabal bench keiki-codec-json:keiki-codec-json-bench@. The +-- baseline numbers are checked in at @bench/baseline.csv@; CI compares +-- new runs against the baseline and flags drift, but DOES NOT block +-- merges. The GHC-9.12 golden hash gate (M5) is the release-blocking +-- gate; the bench is a tracked metric. +module Main (main) where + +import Control.DeepSeq (NFData (..)) +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 (Text) +import Data.Text qualified as T +import Keiki.Codec.JSON (regFileFromJSON, regFileToEncoding, regFileToJSON) +import Keiki.Core (RegFile (..), Slot) +import Keiki.Shape (regFileShapeHash) +import Test.Tasty.Bench (bench, bgroup, defaultMain, nf) + +-- * NFData for RegFile rs (bench-local orphan) ------------------------------- + +-- Bench measurements use 'nf', which needs 'NFData'. Inductive walker +-- forces every slot's value to normal form via the slot type's +-- 'NFData' instance. +class NFDataRegFile (rs :: [Slot]) where + rnfRegFile :: RegFile rs -> () + +instance NFDataRegFile '[] where + rnfRegFile RNil = () + +instance + (NFData t, NFDataRegFile rs) => + NFDataRegFile ('(s, t) ': rs) + where + rnfRegFile (RCons _ x rest) = rnf x `seq` rnfRegFile rest + +instance (NFDataRegFile rs) => NFData (RegFile rs) where + rnf = rnfRegFile + +-- * §10 Case A — Multi-party contract signing (condensed) ------------------- + +-- +-- 5 parties, 50 audit entries → ~5 KB encoded. + +type SlotsA = + '[ '("retryCount", Int), + '("auditLog", [Text]), + '("currentPhase", Text) + ] + +fixtureA :: RegFile SlotsA +fixtureA = + RCons (Proxy @"retryCount") 3 $ + RCons (Proxy @"auditLog") (replicate 50 (T.pack "audit:partial-signature-recorded")) $ + RCons (Proxy @"currentPhase") (T.pack "phase-3-awaiting-final-signature") RNil + +-- * §10 Case B — Long-running batch reconciliation (condensed) -------------- + +-- +-- 5000 processed items → ~250 KB encoded. This is the streaming-encoder +-- motivating case (R10) — the Value path allocates the intermediate +-- @Aeson.Value@ for the whole list; the Encoding path walks slot-by- +-- slot. + +type SlotsB = + '[ '("processedItems", [(Int, Text)]), + '("phase", Text) + ] + +fixtureB :: RegFile SlotsB +fixtureB = + RCons + (Proxy @"processedItems") + [(i, T.pack ("item-result-" <> show i)) | i <- [1 .. 5000]] + $ RCons (Proxy @"phase") (T.pack "reconciling") RNil + +-- * §10 Case C — Customer support ticket aggregate (condensed) -------------- + +-- +-- 100 comments + 10 escalation entries → ~25 KB encoded. + +type SlotsC = + '[ '("comments", [Text]), + '("escalationHistory", [Text]), + '("priority", Text), + '("channel", Text) + ] + +fixtureC :: RegFile SlotsC +fixtureC = + RCons + (Proxy @"comments") + [ T.pack ("comment-" <> show i <> ": " <> "lorem-ipsum-dolor-sit-amet") + | i <- [1 :: Int .. 100] + ] + $ RCons + (Proxy @"escalationHistory") + [T.pack ("escalation-" <> show i) | i <- [1 :: Int .. 10]] + $ RCons (Proxy @"priority") (T.pack "high") + $ RCons (Proxy @"channel") (T.pack "email") RNil + +-- * §10 Case D — Real-time auction aggregate (condensed) -------------------- + +-- +-- 1000 bids → ~50 KB encoded. High-write-rate snapshot pressure. + +type SlotsD = + '[ '("bidHistory", [(Int, Int)]), + '("status", Text), + '("watchers", [Int]) + ] + +fixtureD :: RegFile SlotsD +fixtureD = + RCons + (Proxy @"bidHistory") + [(t, t * 110 + 5000) | t <- [1 :: Int .. 1000]] + $ RCons (Proxy @"status") (T.pack "active") + $ RCons (Proxy @"watchers") [10000 .. 10100] RNil + +-- * Driver ------------------------------------------------------------------- + +main :: IO () +main = do + let bytesA = Aeson.encode (regFileToJSON fixtureA) + bytesB = Aeson.encode (regFileToJSON fixtureB) + bytesC = Aeson.encode (regFileToJSON fixtureC) + bytesD = Aeson.encode (regFileToJSON fixtureD) + -- Force the input bytes so the decode benchmark isn't paying for + -- the encode work as a side effect. + _ <- + pure $! + LBS.length bytesA + + LBS.length bytesB + + LBS.length bytesC + + LBS.length bytesD + defaultMain + [ bgroup + "BenchA_ContractSign" + [ bench "encode-via-Value" $ nf (Aeson.encode . regFileToJSON) fixtureA, + bench "encode-via-Encoding" $ nf (AesonEnc.encodingToLazyByteString . regFileToEncoding) fixtureA, + bench "decode" $ nf (decodeFixtureA) bytesA, + bench "hash" $ nf (\() -> regFileShapeHash (Proxy @SlotsA)) () + ], + bgroup + "BenchB_BatchRecon" + [ bench "encode-via-Value" $ nf (Aeson.encode . regFileToJSON) fixtureB, + bench "encode-via-Encoding" $ nf (AesonEnc.encodingToLazyByteString . regFileToEncoding) fixtureB, + bench "decode" $ nf (decodeFixtureB) bytesB, + bench "hash" $ nf (\() -> regFileShapeHash (Proxy @SlotsB)) () + ], + bgroup + "BenchC_TicketAgg" + [ bench "encode-via-Value" $ nf (Aeson.encode . regFileToJSON) fixtureC, + bench "encode-via-Encoding" $ nf (AesonEnc.encodingToLazyByteString . regFileToEncoding) fixtureC, + bench "decode" $ nf (decodeFixtureC) bytesC, + bench "hash" $ nf (\() -> regFileShapeHash (Proxy @SlotsC)) () + ], + bgroup + "BenchD_Auction" + [ bench "encode-via-Value" $ nf (Aeson.encode . regFileToJSON) fixtureD, + bench "encode-via-Encoding" $ nf (AesonEnc.encodingToLazyByteString . regFileToEncoding) fixtureD, + bench "decode" $ nf (decodeFixtureD) bytesD, + bench "hash" $ nf (\() -> regFileShapeHash (Proxy @SlotsD)) () + ] + ] + +decodeFixtureA :: LBS.ByteString -> Either String (RegFile SlotsA) +decodeFixtureA bs = case Aeson.decode bs of + Nothing -> Left "Aeson.decode failed" + Just v -> regFileFromJSON v + +decodeFixtureB :: LBS.ByteString -> Either String (RegFile SlotsB) +decodeFixtureB bs = case Aeson.decode bs of + Nothing -> Left "Aeson.decode failed" + Just v -> regFileFromJSON v + +decodeFixtureC :: LBS.ByteString -> Either String (RegFile SlotsC) +decodeFixtureC bs = case Aeson.decode bs of + Nothing -> Left "Aeson.decode failed" + Just v -> regFileFromJSON v + +decodeFixtureD :: LBS.ByteString -> Either String (RegFile SlotsD) +decodeFixtureD bs = case Aeson.decode bs of + Nothing -> Left "Aeson.decode failed" + Just v -> regFileFromJSON v diff --git a/bench/baseline.csv b/bench/baseline.csv new file mode 100644 --- /dev/null +++ b/bench/baseline.csv @@ -0,0 +1,17 @@ +Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory +All.BenchA_ContractSign.encode-via-Value,6807769,347816,34269,2,49283072 +All.BenchA_ContractSign.encode-via-Encoding,3387927,264216,16065,0,65011712 +All.BenchA_ContractSign.decode,12882232,1220802,106640,20,65011712 +All.BenchA_ContractSign.hash,1747040,133960,5737,0,65011712 +All.BenchB_BatchRecon.encode-via-Value,1311845312,130324330,6544326,89657,65011712 +All.BenchB_BatchRecon.encode-via-Encoding,890765625,52914452,4256444,105,65011712 +All.BenchB_BatchRecon.decode,2989114062,286069958,16482818,368064,65011712 +All.BenchB_BatchRecon.hash,1784275,106480,5737,0,65011712 +All.BenchC_TicketAgg.encode-via-Value,15564422,1321522,97357,7,65011712 +All.BenchC_TicketAgg.encode-via-Encoding,7660565,566564,57640,0,78643200 +All.BenchC_TicketAgg.decode,30095593,2245184,243181,55,78643200 +All.BenchC_TicketAgg.hash,1799739,107384,5806,0,78643200 +All.BenchD_Auction.encode-via-Value,234994824,16470910,1291776,4027,78643200 +All.BenchD_Auction.encode-via-Encoding,153516113,10548170,778679,16,78643200 +All.BenchD_Auction.decode,521485937,36636576,3347864,16826,78643200 +All.BenchD_Auction.hash,1748992,160464,5772,0,78643200 diff --git a/keiki-codec-json.cabal b/keiki-codec-json.cabal new file mode 100644 --- /dev/null +++ b/keiki-codec-json.cabal @@ -0,0 +1,121 @@ +cabal-version: 3.0 +name: keiki-codec-json +version: 0.1.0.0 +synopsis: Optional JSON codec for keiki's RegFile. +description: + Sibling package to keiki providing a JSON encoder, decoder, and + streaming encoder for @RegFile rs@. The keiki core remains + aeson-free; this package opts in. See keiki's @Keiki.Shape@ + module for the GHC-upgrade-safe shape hash used to discriminate + snapshots — the two halves of the snapshot persistence story. + . + Three methods on @class RegFileToJSON rs@: + . + * @regFileToJSON :: RegFile rs -> Aeson.Value@ — strict + Value-path encoder. + . + * @regFileFromJSON :: Aeson.Value -> Either String (RegFile rs)@ + — strict decoder with per-slot error messages on missing / + extra / type-mismatched fields. + . + * @regFileToEncoding :: RegFile rs -> Aeson.Encoding@ — + streaming encoder over @Aeson.Series@, avoiding the + O(output-size) intermediate @Aeson.Value@ allocation. Recommended + for RegFiles with multi-MB slot values. + . + Also ships a Template Haskell helper module + @Keiki.Codec.JSON.TH@ with @deriveRegFileCodec@ that emits the + three codec functions for a record type with @deriving Generic@. + . + The companion package @keiki-codec-json-test@ ships a property- + test toolkit for downstream consumers (case-#10 ToJSON-change + detector plus library-ised round-trip / sensitivity helpers). + +license: BSD-3-Clause +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: 2026 Nadeem Bitar +category: Codec +build-type: Simple +tested-with: GHC >=9.12 && <9.13 +extra-doc-files: + CHANGELOG.md + CONTRIBUTING.md + README.md + +extra-source-files: bench/baseline.csv + +common warnings + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + +common shared-extensions + default-language: GHC2024 + default-extensions: + AllowAmbiguousTypes + DuplicateRecordFields + FunctionalDependencies + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + UndecidableInstances + +library + import: warnings, shared-extensions + exposed-modules: + Keiki.Codec.JSON + Keiki.Codec.JSON.Event + Keiki.Codec.JSON.TH + + hs-source-dirs: src + build-depends: + , aeson ^>=2.2 + , base ^>=4.21 + , containers ^>=0.7 + , keiki ^>=0.1 + , template-haskell ^>=2.23 + , text ^>=2.1 + +benchmark keiki-codec-json-bench + import: warnings, shared-extensions + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + build-depends: + , aeson ^>=2.2 + , base ^>=4.21 + , bytestring ^>=0.12 + , deepseq ^>=1.5 + , keiki ^>=0.1 + , keiki-codec-json ^>=0.1 + , tasty-bench ^>=0.4 || ^>=0.5 + , text ^>=2.1 + + ghc-options: -fproc-alignment=64 "-with-rtsopts=-A32m -T" + +test-suite keiki-codec-json-test + import: warnings, shared-extensions + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Keiki.Codec.JSON.Fixtures + Keiki.Codec.JSON.GoldenSpec + Keiki.Codec.JSON.PropSpec + Keiki.Codec.JSON.SensitivitySpec + Keiki.Codec.JSON.THEventSpec + Keiki.Codec.JSON.THSpec + + build-depends: + , aeson ^>=2.2 + , base ^>=4.21 + , bytestring ^>=0.12 + , containers ^>=0.7 + , hspec ^>=2.11 + , keiki ^>=0.1 + , keiki-codec-json ^>=0.1 + , QuickCheck ^>=2.15 + , quickcheck-instances ^>=0.3 + , text ^>=2.1 + , time ^>=1.14 diff --git a/src/Keiki/Codec/JSON.hs b/src/Keiki/Codec/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Codec/JSON.hs @@ -0,0 +1,169 @@ +-- | +-- Module : Keiki.Codec.JSON +-- Description : JSON encoder, decoder, and streaming encoder for @RegFile rs@. +-- +-- This module is the public entry point of the @keiki-codec-json@ +-- package. It provides +-- +-- * 'regFileToJSON' — strict 'Aeson.Value' encoder. +-- * 'regFileFromJSON' — strict decoder (rejects missing, extra, or +-- type-mismatched fields with a per-slot error message). +-- * 'regFileToEncoding' — streaming encoder that walks the slot list +-- directly into 'Aeson.Series', avoiding the O(output-size) +-- intermediate 'Aeson.Value' allocation. Use this on RegFiles whose +-- slot /values/ are large (multi-MB) — see §10 case B in +-- @docs\/plans\/36-regfile-json-codec-and-shape-hash-for-snapshot-persistence.md@. +-- +-- The codec is the keiki-side counterpart of the shape hash in +-- @Keiki.Shape@ ("keiki" package). Together they implement the +-- snapshot persistence story: the hash discriminates eligible +-- snapshots (catches structural drift, EP-36 §4 cases #1–9); the +-- codec serialises the eligible ones. +-- +-- == Slot-value size guidance (P11) +-- +-- keiki's per-slot dispatch overhead is microseconds at any realistic +-- slot count (< 1000 slots). The actual cost of encoding is dominated +-- by each slot type's 'Aeson.ToJSON'/'Aeson.FromJSON' instance and the +-- size of the value it carries. The §10 reference cases in EP-36 +-- exhibit RegFiles of 50 KB to 10 MB encoded; this codec serves all of +-- them, but users carrying multi-megabyte slot values should: +-- +-- 1. Call 'regFileToEncoding' (this module) instead of 'regFileToJSON' +-- to avoid the O(output-size) intermediate 'Aeson.Value' allocation. +-- Concretely: use +-- @'Aeson.encodingToLazyByteString' . 'regFileToEncoding'@ instead +-- of @'Aeson.encode' . 'regFileToJSON'@. +-- 2. Consider whether the bulk slot belongs in the RegFile at all — +-- for some workloads, splitting bulk data into a separate event +-- stream and projecting it via subscriptions is structurally +-- cleaner than carrying it in the workflow's RegFile. +module Keiki.Codec.JSON + ( -- * The codec class + RegFileToJSON (..), + + -- * Internal helper (exported so its instances are reachable; users + + -- typically program against 'RegFileToJSON' only) + RegFileWalk, + ) +where + +import Data.Aeson ((.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types qualified as Aeson (Pair) +import Data.Proxy (Proxy (..)) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Keiki.Core (RegFile (..), Slot) + +-- * Internal walker ----------------------------------------------------------- + +-- | Inductive walker over a slot list. Internal helper that powers the +-- three public methods on 'RegFileToJSON'; the auto-derived instances +-- cover any slot list whose components satisfy 'Aeson.ToJSON' and +-- 'Aeson.FromJSON'. Users program against 'RegFileToJSON', not against +-- this class. +class RegFileWalk (rs :: [Slot]) where + -- | The slot list as a flat list of @(Key, Value)@ pairs, in + -- slot-list order. Used to build 'Aeson.Value' via 'Aeson.object'. + regFilePairs :: RegFile rs -> [Aeson.Pair] + + -- | The slot list as an 'Aeson.Series', in slot-list order. Used to + -- build 'Aeson.Encoding' via 'Aeson.pairs', avoiding the + -- 'Aeson.Value' intermediate. + regFileSeries :: RegFile rs -> Aeson.Series + + -- | Consume slots from an 'Aeson.Object', returning the populated + -- 'RegFile' and the leftover keys. The top-level decoder + -- ('regFileFromJSON') uses the leftover to reject extra fields. + regFileReadObject :: + Aeson.Object -> + Either String (RegFile rs, Aeson.Object) + +instance RegFileWalk '[] where + regFilePairs _ = [] + regFileSeries _ = mempty + regFileReadObject km = Right (RNil, km) + +instance + ( KnownSymbol s, + Aeson.ToJSON t, + Aeson.FromJSON t, + RegFileWalk rs + ) => + RegFileWalk ('(s, t) ': rs) + where + regFilePairs (RCons _ x rest) = + let k = Key.fromString (symbolVal (Proxy @s)) + in (k .= x) : regFilePairs rest + + regFileSeries (RCons _ x rest) = + let k = Key.fromString (symbolVal (Proxy @s)) + in (k .= x) <> regFileSeries rest + + regFileReadObject km = + let slotName = symbolVal (Proxy @s) + k = Key.fromString slotName + in case KeyMap.lookup k km of + Nothing -> Left (slotName <> ": missing slot") + Just slotVal -> case Aeson.fromJSON slotVal of + Aeson.Error msg -> Left (slotName <> ": " <> msg) + Aeson.Success x -> do + (rest, km') <- regFileReadObject (KeyMap.delete k km) + Right (RCons (Proxy @s) x rest, km') + +-- * Public class -------------------------------------------------------------- + +-- | The codec class for 'RegFile' slot lists. +-- +-- A slot list @rs@ supports JSON serialisation iff every slot value +-- type carries both 'Aeson.ToJSON' and 'Aeson.FromJSON'. The instance +-- is auto-derived for any such slot list — users do not write +-- 'RegFileToJSON' instances themselves; the structural inductive +-- 'RegFileWalk' instances do the work. +-- +-- The three methods correspond to the three columns in EP-36 §3: +-- +-- * 'regFileToJSON' — R1, strict encoder over 'Aeson.Value'. +-- * 'regFileFromJSON' — R2, strict decoder (missing / extra / type- +-- mismatched fields are 'Left' with a per-slot error message). +-- * 'regFileToEncoding' — R10, streaming encoder over 'Aeson.Encoding' +-- that avoids the 'Aeson.Value' intermediate. +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. + regFileToJSON :: RegFile rs -> Aeson.Value + regFileToJSON = Aeson.object . regFilePairs + + -- | Streaming encoder. Walks the slot list directly into an + -- 'Aeson.Series' via 'Aeson.pairs', avoiding the + -- 'Aeson.Value' intermediate. Recommended for RegFiles with + -- multi-MB slot values; see the module header's "Slot-value size + -- guidance". + regFileToEncoding :: RegFile rs -> Aeson.Encoding + regFileToEncoding = Aeson.pairs . regFileSeries + + -- | Strict decoder. Returns @Left "\: \"@ on any + -- of: missing slot, type-mismatched slot, malformed JSON, or + -- unknown extra field at the top level. + regFileFromJSON :: Aeson.Value -> Either String (RegFile rs) + regFileFromJSON v = case v of + Aeson.Object km -> do + (rf, leftover) <- regFileReadObject km + if KeyMap.null leftover + then Right rf + else + Left + ( "regfile: unknown extra fields: " + <> show (map Key.toString (KeyMap.keys leftover)) + ) + _ -> Left "regfile: expected JSON Object" + +-- | Generic instance: every slot list with the inductive 'RegFileWalk' +-- 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 diff --git a/src/Keiki/Codec/JSON/Event.hs b/src/Keiki/Codec/JSON/Event.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Codec/JSON/Event.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Keiki.Codec.JSON.Event +-- Description : Template Haskell that derives a @kind@-discriminated JSON +-- encoder/decoder skeleton for an event /sum/ type. +-- +-- Where 'Keiki.Codec.JSON.TH.deriveRegFileCodec' handles a single-record +-- snapshot, this module handles an event sum — a @data@ type with several +-- constructors, each wrapping a single record payload (or a no-arg +-- singleton). For +-- +-- > data OrderEvent +-- > = Placed PlacedData +-- > | Shipped ShippedData +-- > | Cancelled +-- > deriving stock (Eq, Show) +-- +-- the splice @$(deriveEventCodecSkeleton opts ''OrderEvent)@ emits four +-- 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 +-- > orderEventKindMap :: [(Data.Text.Text, Data.Text.Text)] -- (ctor, kind) +-- +-- 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. +-- +-- == 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; +-- * else if its name is in 'passthroughFields', the field's own +-- 'Aeson.ToJSON' \/ 'Aeson.FromJSON' instances are used; +-- * otherwise the field is /unhandled/, and 'onMissingCodec' decides: +-- 'FailAtCompileTime' (the default) aborts the splice listing every +-- unhandled field, while 'EmitTodoBindings' emits a clearly-named +-- @_todo_Event_field@ placeholder that compiles but is +-- @error "TODO: ..."@-bodied. +-- +-- There is never a quiet generic guess: adding a field to a payload record +-- forces the author to make a decision at compile time. +-- +-- This module lives in @keiki-codec-json@, not @keiki@ core, because the +-- generated code references @aeson@ and @keiki@ core must stay aeson-free +-- (EP-36 §3 R8; MP-11 Decision Log). It consumes no keiki-core symbols at +-- all; the constructor/field reflection mirrors @keiki@'s +-- @Keiki.Generics.TH@ (@conPayload@, @genTermFieldsRecord@) so the two stay +-- aligned. +-- +-- == 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. +module Keiki.Codec.JSON.Event + ( -- * Options + FieldCodec (..), + OnMissingCodec (..), + EventCodecOptions (..), + defaultEventCodecOptions, + + -- * Splices + deriveEventCodecSkeleton, + deriveEventCodecSkeletonAs, + + -- * Runtime helpers (referenced by generated code; not usually called directly) + lookupField, + lookupText, + aesonResultToEither, + ) +where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Char (toLower) +import Data.List (intercalate) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Language.Haskell.TH + +-- * Public option types ------------------------------------------------------ + +-- | A per-field encode/decode hook. Both fields name top-level functions +-- to splice in (so the hook is untyped at the TH boundary): +-- +-- * 'fcEncode' names a function @fieldType -> Aeson.Value@ (e.g. @idText@); +-- * 'fcDecode' names a function @Aeson.Value -> Either String fieldType@ +-- (e.g. @parseIdText@). +data FieldCodec = FieldCodec + { fcEncode :: Name, + fcDecode :: Name + } + +-- | What to do for a payload field whose name appears in neither +-- 'fieldCodecOverrides' nor 'passthroughFields'. +data OnMissingCodec + = -- | Default: abort the splice with @fail@, listing every unhandled field. + FailAtCompileTime + | -- | Emit a named @_todo_\_\@ stub and route the field + -- through it, so the module compiles but any use throws an + -- obviously-named @error@. + EmitTodoBindings + +-- | Options controlling 'deriveEventCodecSkeleton'. +data EventCodecOptions = EventCodecOptions + { -- | keyed by payload field name (e.g. @"reservationId"@, @"divertStatus"@) + fieldCodecOverrides :: Map String FieldCodec, + -- | field names whose type already has aeson instances and may use them + -- directly (e.g. @"sourceMessageId"@, @"lifeCriticalOverride"@) + passthroughFields :: Set String, + -- | the discriminator key; default @"kind"@ + kindFieldName :: String, + -- | behaviour for unhandled fields; default 'FailAtCompileTime' + onMissingCodec :: OnMissingCodec + } + +-- | Empty overrides, empty passthrough, @kindFieldName = "kind"@, +-- @onMissingCodec = 'FailAtCompileTime'@. +defaultEventCodecOptions :: EventCodecOptions +defaultEventCodecOptions = + EventCodecOptions + { fieldCodecOverrides = Map.empty, + passthroughFields = Set.empty, + kindFieldName = "kind", + onMissingCodec = FailAtCompileTime + } + +-- * Runtime helpers (referenced by generated code) --------------------------- + +-- | Look a key up in a JSON object, with a per-field error on absence. +lookupField :: Key.Key -> Aeson.Object -> Either String Aeson.Value +lookupField k o = case KeyMap.lookup k o of + Just v -> Right v + Nothing -> Left ("missing field: " <> Key.toString k) + +-- | 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 + v <- lookupField k o + case v of + Aeson.String t -> Right t + _ -> Left ("field " <> Key.toString k <> ": expected a string") + +-- | Adapt aeson's 'Aeson.Result' to @Either String@. +aesonResultToEither :: Aeson.Result a -> Either String a +aesonResultToEither (Aeson.Success a) = Right a +aesonResultToEither (Aeson.Error e) = Left e + +-- * Splices ------------------------------------------------------------------ + +-- | Derive the @kind@-discriminated codec skeleton for an event sum type, +-- with the function-name prefix derived from the type name by lower-casing +-- its first letter. +deriveEventCodecSkeleton :: EventCodecOptions -> Name -> Q [Dec] +deriveEventCodecSkeleton opts n = deriveEventCodecSkeletonAs (defaultPrefix n) opts n + +-- | Variant of 'deriveEventCodecSkeleton' taking the prefix explicitly, +-- mirroring 'Keiki.Codec.JSON.TH.deriveRegFileCodecAs'. +deriveEventCodecSkeletonAs :: String -> EventCodecOptions -> Name -> Q [Dec] +deriveEventCodecSkeletonAs prefix opts tyName = do + ctors <- reifyEventCtors tyName + case ctors of + [] -> + fail $ + "deriveEventCodecSkeleton: " + <> show tyName + <> " has no constructors; pass an event sum type." + _ -> pure () + + -- No-silent-fallback safety net: classify each payload field; an + -- unhandled field is one in neither overrides nor passthrough. + let unhandled = + [ (ecCtorName ec, fn, ft) + | ec <- ctors, + (_, fields) <- maybe [] (: []) (ecPayload ec), + (fn, _sel, ft) <- fields, + isUnhandled opts fn + ] + todoBindings <- case onMissingCodec opts of + FailAtCompileTime + | not (null unhandled) -> + fail $ + "deriveEventCodecSkeleton: " + <> show tyName + <> " has field(s) with no provided codec and " + <> "onMissingCodec = FailAtCompileTime:\n" + <> intercalate + "\n" + [ " - " <> nameBase c <> "." <> fn <> " :: " <> pprint ft + | (c, fn, ft) <- unhandled + ] + <> "\nAdd each field to fieldCodecOverrides or passthroughFields, " + <> "or set onMissingCodec = EmitTodoBindings." + | otherwise -> pure [] + EmitTodoBindings -> concat <$> mapM mkTodoBinding unhandled + + let toJSONN = mkName (prefix <> "ToJSON") + fromJSONN = mkName (prefix <> "FromJSON") + eventTypesN = mkName (prefix <> "EventTypes") + kindMapN = mkName (prefix <> "KindMap") + tyT = conT tyName + + -- Encoder: one clause per constructor. + toSig <- sigD toJSONN [t|$tyT -> Aeson.Value|] + toDef <- funD toJSONN (map (encodeClause opts) ctors) + + -- Decoder: a single \v -> case ... clause. + vVar <- newName "v" + oVar <- newName "o" + kVar <- newName "kind" + fromSig <- sigD fromJSONN [t|Aeson.Value -> Either String $tyT|] + fromDef <- + funD + fromJSONN + [ clause + [varP vVar] + (normalB (decoderBody opts prefix vVar oVar kVar ctors)) + [] + ] + + -- Keiro-feeding surfaces: plain Text, no Keiro import. + etSig <- sigD eventTypesN [t|[Text]|] + etDef <- + funD + eventTypesN + [ clause + [] + ( normalB + ( listE + [ [|T.pack $(stringE (nameBase (ecCtorName ec)))|] + | ec <- ctors + ] + ) + ) + [] + ] + kmSig <- sigD kindMapN [t|[(Text, Text)]|] + kmDef <- + funD + kindMapN + [ clause + [] + ( normalB + ( listE + [ [|(T.pack $(stringE nm), T.pack $(stringE nm))|] + | ec <- ctors, + let nm = nameBase (ecCtorName ec) + ] + ) + ) + [] + ] + + pure $ + todoBindings + <> [ toSig, + toDef, + fromSig, + fromDef, + etSig, + etDef, + kmSig, + kmDef + ] + +-- * Encoder generation ------------------------------------------------------- + +-- | One @toJSON@ clause for a constructor. +encodeClause :: EventCodecOptions -> EvCtor -> Q Clause +encodeClause opts ec = case ecPayload ec of + Nothing -> + clause + [conP (ecCtorName ec) []] + (normalB [|Aeson.object [$(kindPair)]|]) + [] + Just (_pc, fields) -> do + pVar <- newName "p" + let pairs = kindPair : map (fieldPair opts (ecCtorName ec) pVar) fields + clause + [conP (ecCtorName ec) [varP pVar]] + (normalB [|Aeson.object $(listE pairs)|]) + [] + where + kindPair = + [| + $(keyE (kindFieldName opts)) + Aeson..= (T.pack $(stringE (nameBase (ecCtorName ec))) :: Text) + |] + +-- | One @"field" .= @ pair. +fieldPair :: EventCodecOptions -> Name -> Name -> (String, Name, Type) -> Q Exp +fieldPair opts ctorName pVar f@(fn, _, _) = + [|$(keyE fn) Aeson..= $(encodeFieldExpr opts ctorName pVar f)|] + +-- | The encoded 'Aeson.Value' for one field of a constructor. +encodeFieldExpr :: EventCodecOptions -> Name -> Name -> (String, Name, Type) -> Q Exp +encodeFieldExpr opts ctorName pVar (fn, sel, _ft) = + case classify opts fn of + Override fc -> [|$(varE (fcEncode fc)) ($(varE sel) $(varE pVar))|] + Passthrough -> [|Aeson.toJSON ($(varE sel) $(varE pVar))|] + Unhandled -> + [|($(varE (todoName ctorName fn)) ($(varE sel) $(varE pVar)) :: Aeson.Value)|] + +-- * Decoder generation ------------------------------------------------------- + +-- | 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 = + caseE + (varE vVar) + [ match + (conP 'Aeson.Object [varP oVar]) + ( normalB + ( infixE + (Just [|lookupText $(keyE (kindFieldName opts)) $(varE oVar)|]) + (varE '(>>=)) + (Just (lamE [varP kVar] (dispatch opts oVar kVar ctors))) + ) + ) + [], + match + wildP + (normalB [|Left $(stringE (prefix <> ": expected a JSON object"))|]) + [] + ] + +-- | Nested @if kind == "C" then else ...@ ending in an +-- unknown-kind 'Left'. +dispatch :: EventCodecOptions -> Name -> Name -> [EvCtor] -> Q Exp +dispatch opts oVar kVar = + foldr + ( \ec elseQ -> + [| + if $(varE kVar) == T.pack $(stringE (nameBase (ecCtorName ec))) + then $(buildCtorDecode opts oVar ec) + else $elseQ + |] + ) + [|Left ("unknown event kind: " <> T.unpack $(varE kVar))|] + +-- | Decode one constructor's payload: @C \<$> (PayloadCtor \<$> d1 \<*> ...)@. +buildCtorDecode :: EventCodecOptions -> Name -> EvCtor -> Q Exp +buildCtorDecode opts oVar ec = case ecPayload ec of + Nothing -> [|Right $(conE (ecCtorName ec))|] + Just (pc, fields) -> + let decs = map (decodeFieldExpr opts oVar (ecCtorName ec)) fields + in [|$(conE (ecCtorName ec)) <$> $(mkApplicative (conE pc) decs)|] + +-- | Build @ctor \<$> d1 \<*> d2 \<*> ...@ (or @Right ctor@ for no fields) +-- in the @Either String@ applicative. +mkApplicative :: Q Exp -> [Q Exp] -> Q Exp +mkApplicative ctorQ [] = [|Right $ctorQ|] +mkApplicative ctorQ (d : ds) = + foldl (\acc x -> [|$acc <*> $x|]) [|$ctorQ <$> $d|] ds + +-- | @Either String fieldType@ decoder for one field. +decodeFieldExpr :: EventCodecOptions -> Name -> Name -> (String, Name, Type) -> Q Exp +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|] + Unhandled -> [|$(varE (todoName ctorName fn)) =<< $getV|] + +-- * TODO bindings ------------------------------------------------------------ + +-- | The placeholder binding name for an unhandled field. +todoName :: Name -> String -> Name +todoName ctorName fn = mkName ("_todo_" <> nameBase ctorName <> "_" <> fn) + +-- | Emit @_todo_C_field :: a; _todo_C_field = error "TODO: ..."@. +mkTodoBinding :: (Name, String, Type) -> Q [Dec] +mkTodoBinding (cn, fn, ft) = do + let nm = todoName cn fn + msg = + "TODO: provide a FieldCodec for " + <> nameBase cn + <> "." + <> fn + <> " :: " + <> pprint ft + aV <- newName "a" + sig <- sigD nm (varT aV) + def <- funD nm [clause [] (normalB [|error $(stringE msg)|]) []] + pure [sig, def] + +-- * Field classification ----------------------------------------------------- + +-- | How one field is encoded/decoded. +data FieldClass + = Override FieldCodec + | Passthrough + | Unhandled + +classify :: EventCodecOptions -> String -> FieldClass +classify opts fn = + case Map.lookup fn (fieldCodecOverrides opts) of + Just fc -> Override fc + Nothing + | fn `Set.member` passthroughFields opts -> Passthrough + | otherwise -> Unhandled + +isUnhandled :: EventCodecOptions -> String -> Bool +isUnhandled opts fn = + not (fn `Map.member` fieldCodecOverrides opts) + && not (fn `Set.member` passthroughFields opts) + +-- * Reflection --------------------------------------------------------------- + +-- | A reflected event constructor: its name plus, for a payload +-- constructor, the payload record's data-constructor name and its +-- @(fieldName, selectorName, fieldType)@ list. 'Nothing' for a singleton. +data EvCtor = EvCtor + { ecCtorName :: Name, + ecPayload :: Maybe (Name, [(String, Name, Type)]) + } + +reifyEventCtors :: Name -> Q [EvCtor] +reifyEventCtors tyName = do + info <- reify tyName + case info of + TyConI (DataD _ _ _ _ ctors _) -> mapM (toEvCtor tyName) ctors + TyConI (NewtypeD _ _ _ _ ctor _) -> mapM (toEvCtor tyName) [ctor] + _ -> + fail $ + "deriveEventCodecSkeleton: expected a data declaration for " + <> show tyName + <> ", got " + <> show info + +toEvCtor :: Name -> Con -> Q EvCtor +toEvCtor tyName con = case con of + NormalC cn [] -> pure (EvCtor cn Nothing) + NormalC cn [(_, payTy)] -> do + payload <- reifyPayloadFields tyName cn payTy + pure (EvCtor cn (Just payload)) + NormalC cn _ -> + fail $ + "deriveEventCodecSkeleton: constructor " + <> nameBase cn + <> " of " + <> show tyName + <> " is multi-argument; wrap a single record payload " + <> "type instead, e.g. `Placed PlacedData`." + RecC cn _ -> + fail $ + "deriveEventCodecSkeleton: constructor " + <> nameBase cn + <> " of " + <> show tyName + <> " uses record syntax directly; wrap a single record " + <> "payload type instead, e.g. `Placed PlacedData`." + _ -> + fail $ + "deriveEventCodecSkeleton: " + <> show tyName + <> " has an unsupported constructor shape (infix or GADT)." + +reifyPayloadFields :: Name -> Name -> Type -> Q (Name, [(String, Name, Type)]) +reifyPayloadFields tyName cn payTy = do + payName <- typeConName payTy + info <- reify payName + case info of + TyConI (DataD _ _ _ _ [RecC pcn fs] _) -> pure (pcn, map field fs) + TyConI (NewtypeD _ _ _ _ (RecC pcn fs) _) -> pure (pcn, map field fs) + _ -> + fail $ + "deriveEventCodecSkeleton: payload of constructor " + <> nameBase cn + <> " in " + <> show tyName + <> " must be a single record-syntax " + <> "constructor type, got " + <> show info + where + field (sel, _, ty) = (nameBase sel, sel, ty) + +typeConName :: Type -> Q Name +typeConName (ConT n) = pure n +typeConName (SigT t _) = typeConName t +typeConName other = + fail $ + "deriveEventCodecSkeleton: payload type must be a type constructor, " + <> "got " + <> show other + +-- * Small helpers ------------------------------------------------------------ + +-- | Lower-case the first character of the type name for the conventional +-- function-name prefix. +defaultPrefix :: Name -> String +defaultPrefix n = case nameBase n of + [] -> error "deriveEventCodecSkeleton: empty type name" + (c : cs) -> toLower c : cs + +-- | An 'Key.fromString'-built JSON key expression. +keyE :: String -> Q Exp +keyE s = [|Key.fromString $(stringE s)|] diff --git a/src/Keiki/Codec/JSON/TH.hs b/src/Keiki/Codec/JSON/TH.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Codec/JSON/TH.hs @@ -0,0 +1,259 @@ +{-# 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 +-- codec functions for plain Haskell record types. +-- +-- A user with a record type +-- +-- @ +-- data MySnapshot = MySnapshot +-- { retryCount :: Int +-- , correlationId :: Text +-- , dispatchedAt :: UTCTime +-- } +-- deriving stock ('Eq', 'Show', GHC.Generics.'GHC.Generics.Generic') +-- @ +-- +-- invokes +-- +-- @ +module Keiki.Codec.JSON.TH + ( deriveRegFileCodec, + deriveRegFileCodecAs, + ) +where + +import Data.Aeson qualified as Aeson +import Data.Char (toLower) +import GHC.Generics qualified as Generics +import Keiki.Codec.JSON (regFileFromJSON, regFileToEncoding, regFileToJSON) +import Keiki.Generics (RegFieldsOf, gFromRegFile, gToRegFile) +import Language.Haskell.TH + ( Con (NormalC, RecC), + Dec (DataD, NewtypeD, TySynD), + Info (TyConI), + Name, + Q, + clause, + conT, + funD, + mkName, + nameBase, + normalB, + reify, + sigD, + ) + +-- | Emit three top-level JSON-codec functions for the record type +-- @t@, with names derived from the type's name by lower-casing the +-- first character. +-- +-- For @t = MySnapshot@ the splice emits +-- +-- * @mySnapshotToJSON :: MySnapshot -> Aeson.Value@ +-- * @mySnapshotToEncoding :: MySnapshot -> Aeson.Encoding@ +-- * @mySnapshotFromJSON :: Aeson.Value -> Either String MySnapshot@ +-- +-- The record must have @deriving (Generic)@ (the splice does not +-- emit a @Generic@ instance). Every field type must have +-- @Aeson.ToJSON@ and @Aeson.FromJSON@ in scope, or compilation fails +-- at the use site of the emitted function with a missing-instance +-- error naming the field's type. +-- +-- The splice rejects: +-- +-- * Type synonyms, classes, value bindings, primitive types — only +-- @data@ and @newtype@ declarations are accepted. +-- * Multi-constructor types (@data Foo = A | B@) — a single slot list +-- cannot represent a sum. +-- * Positional (non-record-syntax) constructors — there are no field +-- names to use as slot symbols. +-- +-- Singleton constructors with no fields (@data Empty = Empty@) are +-- accepted; the slot list is @'[]@ and the emitted functions codec +-- the empty JSON object. +deriveRegFileCodec :: Name -> Q [Dec] +deriveRegFileCodec n = deriveRegFileCodecAs (defaultPrefix n) n + +-- | Variant of 'deriveRegFileCodec' that takes the function-name +-- prefix explicitly. The three emitted functions are named +-- @\ToJSON@, @\ToEncoding@, @\FromJSON@. +deriveRegFileCodecAs :: String -> Name -> Q [Dec] +deriveRegFileCodecAs prefix tyName = do + validateRecord tyName + let recTy = conT tyName + toJSONN = mkName (prefix <> "ToJSON") + toEncN = mkName (prefix <> "ToEncoding") + fromJSONN = mkName (prefix <> "FromJSON") + + toJSONSig <- + sigD + toJSONN + [t|$recTy -> Aeson.Value|] + toJSONDef <- + funD + toJSONN + [ clause + [] + ( normalB + [| + regFileToJSON + @(RegFieldsOf $recTy) + . gToRegFile + . Generics.from + |] + ) + [] + ] + + toEncSig <- + sigD + toEncN + [t|$recTy -> Aeson.Encoding|] + toEncDef <- + funD + toEncN + [ clause + [] + ( normalB + [| + regFileToEncoding + @(RegFieldsOf $recTy) + . gToRegFile + . Generics.from + |] + ) + [] + ] + + fromJSONSig <- + sigD + fromJSONN + [t|Aeson.Value -> Either String $recTy|] + fromJSONDef <- + funD + fromJSONN + [ clause + [] + ( normalB + [| + fmap (Generics.to . gFromRegFile) + . regFileFromJSON + @(RegFieldsOf $recTy) + |] + ) + [] + ] + + pure + [ toJSONSig, + toJSONDef, + toEncSig, + toEncDef, + fromJSONSig, + fromJSONDef + ] + +-- * Internal helpers --------------------------------------------------------- + +-- | Lower-case the first character of the type name to produce the +-- conventional function-name prefix. +defaultPrefix :: Name -> String +defaultPrefix n = case nameBase n of + [] -> error "deriveRegFileCodec: empty type name" + (c : cs) -> toLower c : cs + +-- | Validate that @tyName@ refers to a single-constructor record-syntax +-- @data@ or @newtype@ declaration. Reject every other shape with a +-- precise error message. +validateRecord :: Name -> Q () +validateRecord tyName = do + info <- reify tyName + case info of + TyConI dec -> case dec of + DataD _ _ _ _ ctors _ -> + validateCtors tyName ctors + NewtypeD _ _ _ _ ctor _ -> + validateCtors tyName [ctor] + TySynD {} -> + failure "a type synonym; only `data` and `newtype` are supported" + _ -> + failure + ( "an unsupported declaration shape; only `data` and " + <> "`newtype` are supported" + ) + _ -> + failure + ( "not a type constructor; pass a record type name like " + <> "''MyRecord" + ) + where + failure :: String -> Q a + failure detail = + fail $ "deriveRegFileCodec: " <> show tyName <> " is " <> detail + +-- | Inspect the constructor list. Accept iff there is exactly one +-- constructor, and that constructor is either @RecC@ (record syntax +-- with named fields) or @NormalC@ with zero positional arguments +-- (the no-field singleton case). +validateCtors :: Name -> [Con] -> Q () +validateCtors tyName ctors = case ctors of + [RecC _ _] -> pure () + [NormalC _ []] -> pure () + [NormalC _ _] -> + fail $ + "deriveRegFileCodec: " + <> show tyName + <> " has a positional (non-record-syntax) " + <> "constructor; switch to record syntax so " + <> "field names are available as slot symbols, " + <> "e.g. `data Foo = Foo { x :: Int }`." + [] -> + fail $ + "deriveRegFileCodec: " + <> show tyName + <> " has no constructors; pass a record type." + (_ : _ : _) -> + fail $ + "deriveRegFileCodec: " + <> show tyName + <> " has multiple constructors; a single slot " + <> "list cannot represent a sum type." + _ -> + fail $ + "deriveRegFileCodec: " + <> show tyName + <> " has an unsupported constructor shape " + <> "(infix or GADT); pass a plain record type." diff --git a/test/Keiki/Codec/JSON/Fixtures.hs b/test/Keiki/Codec/JSON/Fixtures.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/Fixtures.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveAnyClass #-} + +-- | Shared fixtures for the property, sensitivity, and golden hash +-- specs. Defines an exemplar slot list (used by every spec as the +-- baseline), schema-evolution mutations of it, and an inductive +-- 'Arbitrary' generator for 'RegFile rs'. +module Keiki.Codec.JSON.Fixtures + ( -- * Baseline slot list + ExemplarSlots, + + -- * Schema-evolution mutations (EP-36 §4 cases #1–9) + AddSlots, + RemoveSlots, + RenameSlots, + ReorderSlots, + TypeChangeSameJsonSlots, + NewtypeWrapSlots, + RecordReplaceSlots, + SplitSlots, + RenamedTypeSlots, + + -- * Auxiliary types for the mutations + OrderId (..), + Address (..), + RenamedAddress (..), + + -- * Arbitrary generator + ArbitraryRegFile (..), + ) +where + +import Data.Aeson qualified as Aeson +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Word (Word32) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol) +-- Arbitrary UTCTime, Text, etc. + +import Keiki.Core (RegFile (..), Slot) +import Keiki.Shape (CanonicalTypeName) +import Test.QuickCheck (Arbitrary (..), Gen) +import Test.QuickCheck.Instances () + +-- * Baseline slot list ------------------------------------------------------- + +-- | Exemplar three-slot list used by every spec as the baseline against +-- which mutations are compared. +type ExemplarSlots = + '[ '("retryCount", Int), + '("cooldownUntil", UTCTime), + '("correlationId", Text) + ] + +-- * Schema-evolution mutations (EP-36 §4) ------------------------------------ + +-- | §4 case #1 — Add slot. A fourth slot is appended to the baseline. +type AddSlots = + '[ '("retryCount", Int), + '("cooldownUntil", UTCTime), + '("correlationId", Text), + '("dispatchedAt", UTCTime) + ] + +-- | §4 case #2 — Remove slot. The baseline minus @correlationId@. +type RemoveSlots = + '[ '("retryCount", Int), + '("cooldownUntil", UTCTime) + ] + +-- | §4 case #3 — Rename slot. @cooldownUntil@ becomes @retryAfter@. +type RenameSlots = + '[ '("retryCount", Int), + '("retryAfter", UTCTime), + '("correlationId", Text) + ] + +-- | §4 case #4 — Reorder slots. @cooldownUntil@ and @retryCount@ swap. +type ReorderSlots = + '[ '("cooldownUntil", UTCTime), + '("retryCount", Int), + '("correlationId", Text) + ] + +-- | §4 case #5 — Slot type change, same JSON. @retryCount@ moves from +-- 'Int' to 'Word32' (both encode identically on positive integers, but +-- the TypeRep differs). +type TypeChangeSameJsonSlots = + '[ '("retryCount", Word32), + '("cooldownUntil", UTCTime), + '("correlationId", Text) + ] + +-- | §4 case #6 — Newtype wrap. @correlationId :: Text@ becomes +-- @correlationId :: OrderId@ where 'OrderId' is a 'Text' newtype with +-- @deriving newtype@ JSON instances. Wire-compatible, but the type's +-- name differs (@OrderId@ vs @Text@) so the hash changes. +type NewtypeWrapSlots = + '[ '("retryCount", Int), + '("cooldownUntil", UTCTime), + '("correlationId", OrderId) + ] + +-- | §4 case #7 — Replace primitive with record. @correlationId :: Text@ +-- becomes @correlationId :: Address@. +type RecordReplaceSlots = + '[ '("retryCount", Int), + '("cooldownUntil", UTCTime), + '("correlationId", Address) + ] + +-- | §4 case #8 — Split slot. @correlationId :: Text@ is split into two +-- slots @correlationStream :: Text@ + @correlationId :: Text@. +type SplitSlots = + '[ '("retryCount", Int), + '("cooldownUntil", UTCTime), + '("correlationStream", Text), + '("correlationId", Text) + ] + +-- | §4 case #9 — Slot type's internal record changes. To exercise the +-- hash's sensitivity here we use a /distinctly-named/ second type +-- 'RenamedAddress' in place of 'Address'. (Two definitions of @data +-- Address@ with different fields cannot coexist in one Haskell +-- module; for the hash to discriminate them they must differ in +-- @tyConModule + tyConName@. The §4 row notes "Maybe (TypeRep)" — the +-- hash flips when the user actually renames the type to signal the +-- breaking change, which is the disciplined practice.) +type RenamedTypeSlots = + '[ '("retryCount", Int), + '("cooldownUntil", UTCTime), + '("correlationId", RenamedAddress) + ] + +-- * Auxiliary types used by the mutations ------------------------------------ + +newtype OrderId = OrderId Text + deriving stock (Eq, Show, Generic) + deriving newtype (Aeson.ToJSON, Aeson.FromJSON, Arbitrary) + deriving anyclass (CanonicalTypeName) + +data Address = Address + { line :: Text, + city :: Text, + postcode :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON, CanonicalTypeName) + +instance Arbitrary Address where + arbitrary = Address <$> arbitrary <*> arbitrary <*> arbitrary + +-- | A distinctly-named near-copy of 'Address' used by 'RenamedTypeSlots' +-- to demonstrate the §4 case #9 detection path (rename-on-breaking- +-- change). Adds a @country@ field to also illustrate the "Address adds +-- country field" example from §4. +data RenamedAddress = RenamedAddress + { line :: Text, + city :: Text, + postcode :: Text, + country :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON, CanonicalTypeName) + +instance Arbitrary RenamedAddress where + arbitrary = + RenamedAddress <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +-- * Arbitrary generator for 'RegFile rs' ------------------------------------- + +-- | Inductive generator over the slot list. Each slot value comes from +-- the slot type's 'Arbitrary' instance. +class ArbitraryRegFile (rs :: [Slot]) where + arbRegFile :: Gen (RegFile rs) + +instance ArbitraryRegFile '[] where + arbRegFile = pure RNil + +instance + ( KnownSymbol s, + Arbitrary t, + ArbitraryRegFile rs + ) => + ArbitraryRegFile ('(s, t) ': rs) + where + arbRegFile = RCons (Proxy @s) <$> arbitrary <*> arbRegFile diff --git a/test/Keiki/Codec/JSON/GoldenSpec.hs b/test/Keiki/Codec/JSON/GoldenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/GoldenSpec.hs @@ -0,0 +1,24 @@ +-- | 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. +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 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" $ + regFileShapeHash (Proxy @ExemplarSlots) + `shouldBe` T.pack "a37b2b77042a635f394a082765f3410ea23a0b89745b0c77242b925a03aa172b" diff --git a/test/Keiki/Codec/JSON/PropSpec.hs b/test/Keiki/Codec/JSON/PropSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/PropSpec.hs @@ -0,0 +1,80 @@ +-- | EP-36 M3 property tests: roundtrip on both encoder paths plus +-- within-path encoding determinism (R9). +-- +-- The Value path and Encoding path are exercised independently. Cross- +-- path byte equality is /not/ asserted because aeson 2.2's +-- @Aeson.Value@ Object iterates 'Aeson.KeyMap' in (alphabetical) +-- KeyMap order, while the Encoding path emits in slot-list order via +-- @Aeson.Series@. See EP-36 Surprises & Discoveries for the +-- 2026-05-13 M2 entry documenting this. +module Keiki.Codec.JSON.PropSpec (spec) where + +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 Keiki.Core (RegFile) +import Test.Hspec (Spec, describe, it) +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 = show . regFileToJSON + +spec :: Spec +spec = do + describe "Roundtrip" $ do + it "Value path round-trips" $ + forAllShow arbRegFile showRegFile valueRoundTrip + it "Encoding path round-trips" $ + forAllShow arbRegFile showRegFile encodingRoundTrip + + describe "Determinism (R9 within-path)" $ do + it "Value path is deterministic" $ + forAllShow arbRegFile showRegFile valueDeterministic + it "Encoding path is deterministic" $ + forAllShow arbRegFile 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 +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 + Left msg -> + False === error ("regFileFromJSON failed: " <> msg) + Right rf' -> + Aeson.encode (regFileToJSON rf') === bytes + +-- | Encoding path round-trip via +-- @regFileFromJSON . fromJust . Aeson.decode . AesonEnc.encodingToLazyByteString . regFileToEncoding@. +encodingRoundTrip :: RegFile ExemplarSlots -> 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 + Left msg -> + False === error ("regFileFromJSON failed: " <> msg) + Right rf' -> + AesonEnc.encodingToLazyByteString (regFileToEncoding rf') === bytes + +-- | Re-encoding the same RegFile via the Value path produces byte- +-- equal output. +valueDeterministic :: RegFile ExemplarSlots -> 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 rf = + AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + === AesonEnc.encodingToLazyByteString (regFileToEncoding rf) diff --git a/test/Keiki/Codec/JSON/SensitivitySpec.hs b/test/Keiki/Codec/JSON/SensitivitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/SensitivitySpec.hs @@ -0,0 +1,55 @@ +-- | EP-36 M3 sensitivity tests (P7.4). +-- +-- The baseline 'ExemplarSlots' shape hash is computed once, and each +-- mutation from EP-36 §4 (cases #1–9) is asserted to produce a /different/ +-- hash. This is the discrimination side of the shape hash contract: any +-- structural change in the slot list must flip the hash. +module Keiki.Codec.JSON.SensitivitySpec (spec) where + +import Data.Proxy (Proxy (..)) +import Keiki.Codec.JSON.Fixtures + ( AddSlots, + ExemplarSlots, + NewtypeWrapSlots, + RecordReplaceSlots, + RemoveSlots, + RenameSlots, + RenamedTypeSlots, + ReorderSlots, + SplitSlots, + TypeChangeSameJsonSlots, + ) +import Keiki.Shape (regFileShapeHash) +import Test.Hspec (Spec, describe, it, shouldSatisfy) + +spec :: Spec +spec = describe "Sensitivity (EP-36 §4 cases #1–9)" $ do + let baseline = regFileShapeHash (Proxy @ExemplarSlots) + + it "#1 add slot flips the hash" $ + regFileShapeHash (Proxy @AddSlots) `shouldSatisfy` (/= baseline) + + it "#2 remove slot flips the hash" $ + regFileShapeHash (Proxy @RemoveSlots) `shouldSatisfy` (/= baseline) + + it "#3 rename slot flips the hash" $ + regFileShapeHash (Proxy @RenameSlots) `shouldSatisfy` (/= baseline) + + it "#4 reorder slots flips the hash (P10)" $ + regFileShapeHash (Proxy @ReorderSlots) `shouldSatisfy` (/= baseline) + + it "#5 slot type change (Int → Word32) flips the hash" $ + regFileShapeHash (Proxy @TypeChangeSameJsonSlots) + `shouldSatisfy` (/= baseline) + + it "#6 newtype wrap (Text → OrderId) flips the hash" $ + regFileShapeHash (Proxy @NewtypeWrapSlots) `shouldSatisfy` (/= baseline) + + it "#7 primitive → record (Text → Address) flips the hash" $ + regFileShapeHash (Proxy @RecordReplaceSlots) `shouldSatisfy` (/= baseline) + + it "#8 split slot flips the hash" $ + regFileShapeHash (Proxy @SplitSlots) `shouldSatisfy` (/= baseline) + + it "#9 type rename (Address → RenamedAddress) flips the hash" $ + regFileShapeHash (Proxy @RenamedTypeSlots) `shouldSatisfy` (/= baseline) diff --git a/test/Keiki/Codec/JSON/THEventSpec.hs b/test/Keiki/Codec/JSON/THEventSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/THEventSpec.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | EP-59 M3 tests for +-- 'Keiki.Codec.JSON.Event.deriveEventCodecSkeleton'. +-- +-- The splice derives a @kind@-discriminated encoder/decoder for an event +-- /sum/ type. This spec exercises round-trip, the @kind@ discriminator, +-- that a per-field override actually runs (rather than a generic instance), +-- and the constructor-name list, against a 3-constructor fixture: one +-- payload event with an overridden newtype field, one all-passthrough +-- payload event, and one singleton. +-- +-- == Negative checks (manual) +-- +-- The no-silent-fallback contract is that an /unhandled/ field (one in +-- neither 'fieldCodecOverrides' nor 'passthroughFields') is never silently +-- given a generic codec. There are two behaviours, neither expressible as a +-- passing unit test: +-- +-- 1. @onMissingCodec = FailAtCompileTime@ (the default). Add a field to a +-- payload record without listing it, e.g. give @PlacedData@ a +-- @discount :: Int@ field and do NOT add @"discount"@ to +-- 'passthroughFields'. Run +-- @cabal build keiki-codec-json:keiki-codec-json-test@. The build must +-- fail with a message of the form: +-- +-- @ +-- deriveEventCodecSkeleton: Keiki.Codec.JSON.THEventSpec.OrderEvent has +-- field(s) with no provided codec and onMissingCodec = FailAtCompileTime: +-- - Placed.discount :: GHC.Types.Int +-- Add each field to fieldCodecOverrides or passthroughFields, or set +-- onMissingCodec = EmitTodoBindings. +-- @ +-- +-- (The type name and field type print fully qualified — @show@/@pprint@ +-- of the reified names.) Revert the field. +-- +-- 2. @onMissingCodec = EmitTodoBindings@. With the same unhandled field but +-- @onMissingCodec = EmitTodoBindings@ in the options, the build SUCCEEDS +-- and a top-level binding @_todo_Placed_discount :: a@ is emitted whose +-- body is @error "TODO: provide a FieldCodec for Placed.discount :: Int"@. +-- Any actual encode/decode of that field throws the named error rather +-- than guessing. Verify by adding @discount@, switching to +-- @EmitTodoBindings@, and observing the module compiles; referencing +-- @_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 + +import Data.Aeson qualified as Aeson +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 (..), + defaultEventCodecOptions, + deriveEventCodecSkeleton, + ) +import Test.Hspec (Spec, describe, it, shouldBe) +import Text.Read (readMaybe) + +-- * Fixtures ----------------------------------------------------------------- + +-- | A newtype field whose JSON form is overridden (a @"ord-"@ string), +-- proving the override hook runs instead of a generic 'Int' encoding. +newtype OrderId = OrderId Int + deriving stock (Eq, Show) + +orderIdToJSON :: OrderId -> Aeson.Value +orderIdToJSON (OrderId n) = Aeson.toJSON (T.pack ("ord-" <> show n)) + +orderIdFromJSON :: Aeson.Value -> Either String OrderId +orderIdFromJSON v = case v of + Aeson.String t + | Just rest <- T.stripPrefix (T.pack "ord-") t, + Just n <- readMaybe (T.unpack rest) -> + Right (OrderId n) + _ -> Left "orderIdFromJSON: expected an \"ord-\" string" + +data PlacedData = PlacedData + { orderId :: OrderId, + qty :: Int + } + deriving stock (Eq, Show) + +data ShippedData = ShippedData + { trackingNo :: Text + } + deriving stock (Eq, Show) + +data OrderEvent + = Placed PlacedData + | Shipped ShippedData + | Cancelled + deriving stock (Eq, Show) + +$( deriveEventCodecSkeleton + defaultEventCodecOptions + { fieldCodecOverrides = + Map.fromList [("orderId", FieldCodec 'orderIdToJSON 'orderIdFromJSON)], + passthroughFields = Set.fromList ["qty", "trackingNo"] + } + ''OrderEvent + ) + +-- * Spec -------------------------------------------------------------------- + +spec :: Spec +spec = describe "deriveEventCodecSkeleton" $ do + let placed = Placed (PlacedData (OrderId 7) 3) + shipped = Shipped (ShippedData (T.pack "1Z999")) + cancelled = Cancelled + + describe "round-trip (decode . encode == Right)" $ do + it "Placed (payload with an overridden field) round-trips" $ + orderEventFromJSON (orderEventToJSON placed) `shouldBe` Right placed + + it "Shipped (all-passthrough payload) round-trips" $ + orderEventFromJSON (orderEventToJSON shipped) `shouldBe` Right shipped + + it "Cancelled (singleton) round-trips" $ + orderEventFromJSON (orderEventToJSON cancelled) `shouldBe` Right cancelled + + describe "kind discriminator + override usage" $ do + -- orderEventToJSON (Placed (PlacedData (OrderId 7) 3)) + -- == {"kind":"Placed","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), + "orderId" Aeson..= (T.pack "ord-7" :: Text), + "qty" Aeson..= (3 :: Int) + ] + + it "the orderId override ran (string \"ord-7\", not the integer 7)" $ + -- If a generic Int codec had been silently used, this would be 7. + orderEventFromJSON + ( Aeson.object + [ "kind" Aeson..= (T.pack "Placed" :: Text), + "orderId" Aeson..= (T.pack "ord-7" :: Text), + "qty" Aeson..= (3 :: Int) + ] + ) + `shouldBe` Right placed + + it "Cancelled encodes to just the kind object" $ + orderEventToJSON cancelled + `shouldBe` Aeson.object ["kind" Aeson..= (T.pack "Cancelled" :: Text)] + + 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) + + 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" $ + orderEventEventTypes + `shouldBe` map T.pack ["Placed", "Shipped", "Cancelled"] + + it "KindMap pairs each constructor name with its kind string" $ + orderEventKindMap + `shouldBe` [ (T.pack "Placed", T.pack "Placed"), + (T.pack "Shipped", T.pack "Shipped"), + (T.pack "Cancelled", T.pack "Cancelled") + ] diff --git a/test/Keiki/Codec/JSON/THSpec.hs b/test/Keiki/Codec/JSON/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/THSpec.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | EP-38 M3 tests for 'Keiki.Codec.JSON.TH.deriveRegFileCodec'. +-- +-- The splice emits three top-level functions per record type. This spec +-- exercises the round-trip and strict-decoder properties of the emitted +-- functions against two test records — a non-trivial @TestRec@ and the +-- @Empty@ singleton — and verifies the encoding-path / value-path +-- semantic-round-trip agreement (the same invariant the in-tree M2 and +-- M3 specs exercise for the underlying class). +-- +-- == Negative-test procedure (manual) +-- +-- The splice's contract is that a record whose field type lacks +-- 'Aeson.ToJSON' or 'Aeson.FromJSON' fails to compile. This is not +-- expressible in a passing unit test, so the procedure is manual: +-- +-- 1. Edit @TestRec@ below to add a field @trBad :: Int -> Int@. +-- 2. Run @cabal build keiki-codec-json:keiki-codec-json-test@. +-- 3. The build must fail with @No instance for 'Aeson.ToJSON' (Int -> Int)@ +-- pointing at the use site of @testRecToJSON@. +-- 4. Revert. The expected error proves the splice's elaboration trips +-- the missing-instance check; an automated should-not-compile test +-- is out of scope for v0.2. +module Keiki.Codec.JSON.THSpec (spec) where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Encoding qualified as AesonEnc +import Data.Maybe (fromJust) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Keiki.Codec.JSON.TH (deriveRegFileCodec) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- * Test fixtures ----------------------------------------------------------- + +-- | Non-trivial two-field record used to exercise round-trip and strict +-- decoder behaviour. +data TestRec = TestRec + { trCount :: Int, + trNote :: Text + } + deriving stock (Eq, Show, Generic) + +$(deriveRegFileCodec ''TestRec) + +-- | Singleton record used to exercise the empty-slot-list edge case. +data Empty = Empty + deriving stock (Eq, Show, Generic) + +$(deriveRegFileCodec ''Empty) + +-- * Spec -------------------------------------------------------------------- + +spec :: Spec +spec = describe "deriveRegFileCodec" $ do + let tr = TestRec {trCount = 7, trNote = T.pack "hi"} + + describe "TestRec — round-trip and encoding agreement" $ do + it "Value path round-trips" $ + testRecFromJSON (testRecToJSON tr) `shouldBe` Right tr + + it "Encoding path bytes parse back to the same value" $ do + let bytes = AesonEnc.encodingToLazyByteString (testRecToEncoding tr) + v = fromJust (Aeson.decode bytes :: Maybe Aeson.Value) + testRecFromJSON v `shouldBe` Right tr + + it "Value path emits both slots in slot-list order" $ + testRecToJSON tr + `shouldBe` Aeson.object + [ "trCount" Aeson..= (7 :: Int), + "trNote" Aeson..= T.pack "hi" + ] + + describe "TestRec — strict decoder" $ do + it "rejects an Object missing trCount with a slot-prefixed message" $ do + let v = Aeson.object ["trNote" Aeson..= T.pack "hi"] + testRecFromJSON v `shouldBe` Left "trCount: missing slot" + + it "rejects an Object with an unknown extra field" $ do + let v = + Aeson.object + [ "trCount" Aeson..= (7 :: Int), + "trNote" Aeson..= T.pack "hi", + "bogus" Aeson..= (1 :: Int) + ] + testRecFromJSON v `shouldSatisfy` isExtraFieldsLeft + + it "rejects a type-mismatched field with a slot-prefixed message" $ do + let v = + Aeson.object + [ "trCount" Aeson..= T.pack "seven", + "trNote" Aeson..= T.pack "hi" + ] + testRecFromJSON v `shouldSatisfy` hasPrefix "trCount:" + + describe "Empty — empty-slot-list edge case" $ do + it "encodes Empty to the empty JSON object" $ + emptyToJSON Empty `shouldBe` Aeson.object [] + + it "decodes the empty JSON object back to Empty" $ + emptyFromJSON (Aeson.object []) `shouldBe` Right Empty + + it "encodes Empty via the streaming path to the literal bytes {}" $ + AesonEnc.encodingToLazyByteString (emptyToEncoding Empty) + `shouldBe` AesonEnc.encodingToLazyByteString (AesonEnc.pairs mempty) + + it "rejects a non-empty JSON object as unknown extra fields" $ + emptyFromJSON (Aeson.object ["x" Aeson..= (1 :: Int)]) + `shouldSatisfy` isExtraFieldsLeft + +-- * Helpers ----------------------------------------------------------------- + +isExtraFieldsLeft :: Either String a -> Bool +isExtraFieldsLeft = \case + Left msg -> T.pack "regfile: unknown extra fields:" `T.isPrefixOf` T.pack msg + Right _ -> False + +hasPrefix :: String -> Either String a -> Bool +hasPrefix p = \case + Left msg -> T.pack p `T.isPrefixOf` T.pack msg + Right _ -> False diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,196 @@ +-- | EP-36 M2 unit tests for the JSON codec. +-- +-- Covers acceptance items from the milestone: empty RegFile encode / +-- decode on both paths (Value and Encoding); a single-slot list; a +-- multi-slot list with both encoders producing the same bytes after +-- @'Aeson.encode'@ / @'AesonEnc.encodingToLazyByteString'@; strict failure +-- on missing slot, extra slot, type mismatch. +module Main (main) where + +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.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.GoldenSpec qualified +import Keiki.Codec.JSON.PropSpec qualified +import Keiki.Codec.JSON.SensitivitySpec qualified +import Keiki.Codec.JSON.THEventSpec qualified +import Keiki.Codec.JSON.THSpec qualified +import Keiki.Core (RegFile (..)) +import Test.Hspec + ( Spec, + describe, + hspec, + it, + shouldBe, + ) + +main :: IO () +main = hspec $ do + spec + 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-38 deriveRegFileCodec" Keiki.Codec.JSON.THSpec.spec + describe "EP-59 deriveEventCodecSkeleton" Keiki.Codec.JSON.THEventSpec.spec + +spec :: Spec +spec = do + describe "Empty RegFile" $ do + it "encodes to {}" $ + regFileToJSON (RNil :: RegFile '[]) + `shouldBe` Aeson.object [] + + it "encodes via streaming to the same bytes as the Value path" $ + AesonEnc.encodingToLazyByteString (regFileToEncoding (RNil :: RegFile '[])) + `shouldBe` Aeson.encode (regFileToJSON (RNil :: RegFile '[])) + + it "decodes {} back to RNil" $ do + let r = regFileFromJSON @'[] (Aeson.object []) + case r of + Right RNil -> (True :: Bool) `shouldBe` True + Left msg -> error ("expected Right RNil, got Left " <> msg) + + it "rejects {\"x\": 1} as having unknown extra fields" $ do + let r = regFileFromJSON @'[] (Aeson.object ["x" Aeson..= (1 :: Int)]) + isExtraFieldsLeft r `shouldBe` True + + describe "Single-slot RegFile '[ '(\"retryCount\", Int) ]" $ do + let rf = RCons (Proxy @"retryCount") (3 :: Int) RNil :: RegFile '[ '("retryCount", Int)] + + it "encodes to {\"retryCount\": 3}" $ + regFileToJSON rf + `shouldBe` Aeson.object ["retryCount" Aeson..= (3 :: Int)] + + it "encodes via streaming to byte-equal bytes" $ + AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + `shouldBe` Aeson.encode (regFileToJSON rf) + + it "round-trips through the Value path" $ do + let r = regFileFromJSON @'[ '("retryCount", Int)] (regFileToJSON rf) + case r of + Right (RCons _ n RNil) -> n `shouldBe` 3 + Left msg -> error ("expected round-trip success, got Left " <> msg) + + it "round-trips through the Encoding path" $ do + let bytes = AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + v = fromJust (Aeson.decode bytes :: Maybe Aeson.Value) + r = regFileFromJSON @'[ '("retryCount", Int)] v + case r of + Right (RCons _ n RNil) -> n `shouldBe` 3 + Left msg -> error ("expected round-trip success, got Left " <> msg) + + it "rejects {} as missing retryCount" $ do + let r = regFileFromJSON @'[ '("retryCount", Int)] (Aeson.object []) + case r of + Left msg -> msg `shouldBe` "retryCount: missing slot" + Right _ -> error "expected Left, got Right" + + it "rejects {\"retryCount\": \"three\"} as type mismatch" $ do + let r = + regFileFromJSON @'[ '("retryCount", Int)] + (Aeson.object ["retryCount" Aeson..= ("three" :: Text)]) + case r of + Left msg + | "retryCount:" `T.isPrefixOf` T.pack msg -> + (True :: Bool) `shouldBe` True + Left msg -> error ("expected slot-prefixed type error, got " <> msg) + Right _ -> error "expected Left, got Right" + + it "rejects {\"retryCount\": 3, \"extra\": 1} as unknown extra fields" $ do + let r = + regFileFromJSON @'[ '("retryCount", Int)] + ( Aeson.object + [ "retryCount" Aeson..= (3 :: Int), + "extra" Aeson..= (1 :: Int) + ] + ) + isExtraFieldsLeft r `shouldBe` True + + describe "Multi-slot RegFile (Int + Text)" $ do + let rf :: RegFile '[ '("retryCount", Int), '("note", Text)] + rf = + RCons (Proxy @"retryCount") (5 :: Int) $ + RCons (Proxy @"note") ("hello" :: Text) RNil + + it "encodes both slots in slot-list order via Value path" $ + regFileToJSON rf + `shouldBe` Aeson.object + [ "retryCount" Aeson..= (5 :: Int), + "note" Aeson..= ("hello" :: Text) + ] + + -- The Value path emits keys in 'Aeson.KeyMap' order (alphabetical for + -- aeson 2.2's default backing 'Map Key'); the Encoding path emits in + -- slot-list order. The two byte streams therefore differ when slot + -- order is not alphabetical. What both paths guarantee is /semantic/ + -- round-trip equality plus within-path determinism — see the next + -- two tests. + it "Encoding path emits keys in slot-list order; Value path is sorted" $ do + let viaStreaming = AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + viaValue = Aeson.encode (regFileToJSON rf) + viaStreaming + `shouldBe` LBS.pack + ( map + (fromIntegral . fromEnum) + "{\"retryCount\":5,\"note\":\"hello\"}" + ) + viaValue + `shouldBe` LBS.pack + ( map + (fromIntegral . fromEnum) + "{\"note\":\"hello\",\"retryCount\":5}" + ) + + it "both paths round-trip to the same RegFile (cross-path semantic equality)" $ do + let valueBytes = Aeson.encode (regFileToJSON rf) + streamBytes = AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + fromValue = + regFileFromJSON @'[ '("retryCount", Int), '("note", Text)] + =<< maybe (Left "decode failed") Right (Aeson.decode valueBytes) + fromStream = + regFileFromJSON @'[ '("retryCount", Int), '("note", Text)] + =<< maybe (Left "decode failed") Right (Aeson.decode streamBytes) + assertMultiRoundTrip fromValue + assertMultiRoundTrip fromStream + + it "within-path determinism: re-encoding produces byte-equal output (R9)" $ do + Aeson.encode (regFileToJSON rf) + `shouldBe` Aeson.encode (regFileToJSON rf) + AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + `shouldBe` AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + + it "rejects {\"retryCount\": 5} as missing note" $ do + let r = + regFileFromJSON + @'[ '("retryCount", Int), '("note", Text)] + (Aeson.object ["retryCount" Aeson..= (5 :: Int)]) + case r of + Left msg -> msg `shouldBe` "note: missing slot" + Right _ -> error "expected Left, got Right" + +isExtraFieldsLeft :: Either String a -> Bool +isExtraFieldsLeft = \case + Left msg -> "regfile: unknown extra fields:" `T.isPrefixOf` T.pack msg + Right _ -> False + +assertMultiRoundTrip :: + Either String (RegFile '[ '("retryCount", Int), '("note", Text)]) -> + IO () +assertMultiRoundTrip = \case + Right (RCons _ n (RCons _ t RNil)) -> do + n `shouldBe` 5 + t `shouldBe` ("hello" :: Text) + Left msg -> error ("expected round-trip success, got Left " <> msg) + +-- Silence GHC's unused-import warnings: Symbol/Type are referenced by +-- the type-level slot lists above, but GHC's warning pass doesn't see +-- the kind annotations as references. +_unused :: (Proxy (rs :: [(Symbol, Type)]), ()) +_unused = (Proxy, ())