keiro-core 0.3.0.0 → 0.4.0.1

raw patch · 6 files changed

+365/−27 lines, 6 filesdep ~aesondep ~aeson-casingdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, aeson-casing, bytestring, deepseq, generic-lens, keiki, lens, scientific, text, time, uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +31/−1
• keiro-core.cabal +14/−12
• src/Keiro/Codec/Structural.hs +82/−0
• src/Keiro/Codec/Structural/Generic.hs +119/−0
• src/Keiro/EventStream.hs +15/−7
• src/Keiro/EventStream/Validate.hs +104/−7

@@ -6,7 +6,37 @@  ## [Unreleased] -_No unreleased changes._+## 0.4.0.1 — 2026-07-28++### Other Changes++- Adds PVP upper bounds to every dependency that previously carried a lower+  bound only, so `cabal check` reports no packaging warnings. No API or+  behaviour change from 0.4.0.0, which was tagged but never published.+++## 0.4.0.0 — 2026-07-28++### Breaking Changes++- `StateCodec` includes the control-state/fold shape discriminator used with+  the register-layout hash; stale snapshot seeds are invalidated when either+  executable state shape changes.+- Validated event-stream construction rejects invalid event codec schemas,+  tags, and upcaster chains at assembly. `mkEventStreamUnchecked` remains the+  explicit emergency-forensics bypass.+- Requires Keiki 0.4 and handles its typed projection terms and validation+  findings explicitly.++### New Features++- Adds the stable `Keiro.Codec.Structural` integration surface for generated+  structural codecs: total `StructuralBinding` values, deterministic labelled+  `FixtureCases`, both binding-law helpers, and one-way JSON delegation helpers.+- Adds `Keiro.Codec.Structural.Generic.genericStructuralBinding`, an opt-in+  nominal adapter that accepts only exact constructor, selector, arity, order,+  and field-type correspondence and otherwise emits a compile-time direction+  to the scaffolded binding module.  ## 0.3.0.0 — 2026-07-14 

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            keiro-core-version:         0.3.0.0+version:         0.4.0.1 synopsis:        Core contracts for Keiro packages description:   Stable stream, codec, event-stream, and integration-event contracts@@ -40,6 +40,8 @@   import:          warnings, shared   exposed-modules:     Keiro.Codec+    Keiro.Codec.Structural+    Keiro.Codec.Structural.Generic     Keiro.EventStream     Keiro.EventStream.Validate     Keiro.Integration.Event@@ -50,16 +52,16 @@    hs-source-dirs:  src   build-depends:-    , aeson         >=2.2-    , aeson-casing  >=0.2+    , aeson         >=2.2  && <2.3+    , aeson-casing  >=0.2  && <0.3     , base          >=4.21 && <5-    , bytestring    >=0.11-    , deepseq       >=1.5-    , generic-lens  >=2.2-    , keiki         >=0.2  && <0.3+    , bytestring    >=0.11 && <0.13+    , deepseq       >=1.5  && <1.6+    , generic-lens  >=2.2  && <2.4+    , keiki         >=0.4  && <0.5     , kiroku-store  >=0.3  && <0.4-    , lens          >=5.2-    , scientific    >=0.3-    , text          >=2.1-    , time          >=1.12-    , uuid          >=1.3+    , lens          >=5.2  && <5.4+    , scientific    >=0.3  && <0.4+    , text          >=2.1  && <2.2+    , time          >=1.12 && <1.15+    , uuid          >=1.3  && <1.4

@@ -0,0 +1,82 @@+{- | Stable runtime contract between consumer-owned domain types and+Keiro-generated structural wire shapes.++Stability: this module is a published integration point for consumer binding+modules and @keiro-dsl@ generated code. Its types and record field names are+stable within a major version. Additions are permitted; renames or semantic+changes require a major version bump and a coordinated @keiro-dsl@ release.++The generated codec is the single authority for the wire schema. A consumer+'Data.Aeson.ToJSON' or 'Data.Aeson.FromJSON' instance may delegate to that+generated codec through a binding, but Keiro never delegates structural+encoding to a consumer instance.+-}+module Keiro.Codec.Structural (+    StructuralBinding (..),+    FixtureCases (..),+    bindingDomainRoundTrip,+    bindingShapeRoundTrip,+    encodeViaBinding,+    decodeViaBinding,+)+where++import Data.Aeson (Value)+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)++{- | A total construction and destruction boundary between a consumer-owned+type and its declared structural shape.++Consumer invariants must be represented by the shape. If converting a valid+shape into the consumer type can fail, the declaration is not structural and+must use Keiro's opaque mapping mode instead.+-}+data StructuralBinding a shape = StructuralBinding+    { bindingToShape :: !(a -> shape)+    , bindingFromShape :: !(shape -> a)+    }++{- | Deterministic, labelled consumer values used by generated conformance+harnesses.++The generator checks these cases against every declared union and nullable+branch. Values are never invented through @Arbitrary@ or @Default@. Generated+harnesses also reject empty or duplicate labels so failures keep a stable+identity.+-}+newtype FixtureCases a = FixtureCases+    { fixtureCases :: NonEmpty (Text, a)+    }+    deriving stock (Eq, Show)++-- | Check that a consumer value survives conversion through its shape.+bindingDomainRoundTrip :: (Eq a) => StructuralBinding a shape -> a -> Bool+bindingDomainRoundTrip binding value =+    bindingFromShape binding (bindingToShape binding value) == value++-- | Check that every declared shape survives conversion through the consumer type.+bindingShapeRoundTrip :: (Eq shape) => StructuralBinding a shape -> shape -> Bool+bindingShapeRoundTrip binding shape =+    bindingToShape binding (bindingFromShape binding shape) == shape++{- | Encode a consumer value by first converting it to the generated shape.++This is the sanctioned delegation direction for a consumer-owned JSON+instance: the generated shape encoder remains the wire authority.+-}+encodeViaBinding :: StructuralBinding a shape -> (shape -> Value) -> a -> Value+encodeViaBinding binding encodeShape = encodeShape . bindingToShape binding++{- | Decode the generated shape and then apply the binding's total constructor.++All failure comes from parsing JSON into the generated shape. Applying the+binding introduces no hidden semantic rejection.+-}+decodeViaBinding ::+    StructuralBinding a shape ->+    (Value -> Either Text shape) ->+    Value ->+    Either Text a+decodeViaBinding binding decodeShape value =+    bindingFromShape binding <$> decodeShape value

@@ -0,0 +1,119 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Exact, opt-in nominal derivation for structural bindings.++The derivation supplies only nominal construction and destruction; wire keys,+union tags, presence, nullability, and defaults remain exclusively in the+@.keiro@ spec and the generated codec. Exact representation mismatches fail at+compile time; both binding laws and finite codec cases remain required evidence+against implementation defects and semantic mistakes.+-}+module Keiro.Codec.Structural.Generic (+    GNominalBinding,+    genericStructuralBinding,+) where++import Data.Kind (Constraint, Type)+import GHC.Generics+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Keiro.Codec.Structural (StructuralBinding (..))++{- | Generic representations with identical constructor names, selector names,+field order, arity, and field types. There are deliberately no coercion,+prefix-stripping, or positional-only options.+-}+class GNominalBinding (domain :: Type -> Type) (shape :: Type -> Type) where+    gNominalToShape :: domain parameter -> shape parameter+    gNominalFromShape :: shape parameter -> domain parameter++instance {-# OVERLAPPING #-} (GNominalBinding domain shape) => GNominalBinding (M1 D domainMeta domain) (M1 D shapeMeta shape) where+    gNominalToShape (M1 value) = M1 (gNominalToShape value)+    gNominalFromShape (M1 value) = M1 (gNominalFromShape value)++instance {-# OVERLAPPING #-} (SameConstructor domainMeta shapeMeta, GNominalBinding domain shape) => GNominalBinding (M1 C domainMeta domain) (M1 C shapeMeta shape) where+    gNominalToShape (M1 value) = M1 (gNominalToShape value)+    gNominalFromShape (M1 value) = M1 (gNominalFromShape value)++instance {-# OVERLAPPING #-} (SameSelector domainMeta shapeMeta, GNominalBinding domain shape) => GNominalBinding (M1 S domainMeta domain) (M1 S shapeMeta shape) where+    gNominalToShape (M1 value) = M1 (gNominalToShape value)+    gNominalFromShape (M1 value) = M1 (gNominalFromShape value)++instance {-# OVERLAPPING #-} (GNominalBinding domainLeft shapeLeft, GNominalBinding domainRight shapeRight) => GNominalBinding (domainLeft :*: domainRight) (shapeLeft :*: shapeRight) where+    gNominalToShape (left :*: right) = gNominalToShape left :*: gNominalToShape right+    gNominalFromShape (left :*: right) = gNominalFromShape left :*: gNominalFromShape right++instance {-# OVERLAPPING #-} (GNominalBinding domainLeft shapeLeft, GNominalBinding domainRight shapeRight) => GNominalBinding (domainLeft :+: domainRight) (shapeLeft :+: shapeRight) where+    gNominalToShape (L1 value) = L1 (gNominalToShape value)+    gNominalToShape (R1 value) = R1 (gNominalToShape value)+    gNominalFromShape (L1 value) = L1 (gNominalFromShape value)+    gNominalFromShape (R1 value) = R1 (gNominalFromShape value)++instance {-# OVERLAPPING #-} GNominalBinding (K1 domainIndex value) (K1 shapeIndex value) where+    gNominalToShape (K1 value) = K1 value+    gNominalFromShape (K1 value) = K1 value++instance {-# OVERLAPPING #-} GNominalBinding U1 U1 where+    gNominalToShape U1 = U1+    gNominalFromShape U1 = U1++instance {-# OVERLAPPING #-} GNominalBinding V1 V1 where+    gNominalToShape value = case value of {}+    gNominalFromShape value = case value of {}++instance+    {-# OVERLAPPABLE #-}+    ( TypeError+        ( 'Text "keiro structural binding has no exact nominal correspondence between "+            ':<>: 'ShowType domain+            ':<>: 'Text " and "+            ':<>: 'ShowType shape+            ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module."+        )+    ) =>+    GNominalBinding domain shape+    where+    gNominalToShape _ = error "unreachable: TypeError prevents generic structural binding construction"+    gNominalFromShape _ = error "unreachable: TypeError prevents generic structural binding construction"++type family SameConstructor (domainMeta :: Meta) (shapeMeta :: Meta) :: Constraint where+    SameConstructor ('MetaCons name domainFixity domainRecord) ('MetaCons name shapeFixity shapeRecord) = ()+    SameConstructor ('MetaCons domainName domainFixity domainRecord) ('MetaCons shapeName shapeFixity shapeRecord) =+        TypeError+            ( 'Text "keiro structural binding constructor mismatch: "+                ':<>: 'ShowType domainName+                ':<>: 'Text " versus "+                ':<>: 'ShowType shapeName+                ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module."+            )++type family SameSelector (domainMeta :: Meta) (shapeMeta :: Meta) :: Constraint where+    SameSelector ('MetaSel name domainUnpack domainStrict domainDecided) ('MetaSel name shapeUnpack shapeStrict shapeDecided) = ()+    SameSelector ('MetaSel domainName domainUnpack domainStrict domainDecided) ('MetaSel shapeName shapeUnpack shapeStrict shapeDecided) =+        TypeError+            ( 'Text "keiro structural binding selector mismatch: "+                ':<>: 'ShowType domainName+                ':<>: 'Text " versus "+                ':<>: 'ShowType shapeName+                ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module."+            )++-- | Derive a total binding when both generic representations correspond exactly.+genericStructuralBinding ::+    ( Generic domain+    , Generic shape+    , GNominalBinding (Rep domain) (Rep shape)+    ) =>+    StructuralBinding domain shape+genericStructuralBinding =+    StructuralBinding+        { bindingToShape = to . gNominalToShape . from+        , bindingFromShape = to . gNominalFromShape . from+        }

@@ -87,21 +87,29 @@  {- | How to serialize and deserialize a stream's snapshot state. -'stateCodecVersion' and 'shapeHash' together gate snapshot reuse: a stored-snapshot is only loaded when both match the current codec, so a change to-the snapshot encoding or to the shape of the folded state invalidates older-snapshots and forces a clean rehydration from events.+'stateCodecVersion', 'shapeHash', and 'stateShapeHash' together gate snapshot+reuse: a stored snapshot is only loaded when all three match the current+codec, so incompatible encodings, register layouts, and control-state shapes+invalidate older snapshots and force a clean rehydration from events.  * 'stateCodecVersion' — bumped when the snapshot encoding changes-  incompatibly.-* 'shapeHash' — a digest of the folded-state shape; protects against-  silently loading a snapshot whose structure no longer matches.+  incompatibly, and whenever fold logic changes in a way the structural hashes+  and any composed fold fingerprint cannot see.+* 'shapeHash' — a digest of the register-file layout.+* 'stateShapeHash' — a digest of the control-state shape, optionally composed+  with a fold fingerprint. * 'encode' \/ 'decode' — the JSON serialization of the @(state,   registers)@ pair.++Hand-written guard and update function bodies are not structurally+inspectable. Changing them without also changing a composed fold fingerprint+MUST bump 'stateCodecVersion'; otherwise an old snapshot can still match and+be served as a stale hydration seed. -} data StateCodec state = StateCodec     { stateCodecVersion :: !Int     , shapeHash :: !Text+    , stateShapeHash :: !Text     , encode :: !(state -> Value)     , decode :: !(Value -> Either Text state)     }

@@ -8,6 +8,10 @@ also checks guard determinism and structural reachability. This module lifts keiki's umbrella check ('Keiki.validateTransducer') to the 'EventStream' boundary so a service can assert all of its streams are sound before hydration.+The boundary also validates the event 'Keiro.Codec.Codec' construction+invariants, so malformed schema versions, duplicate event tags or upcaster+sources, out-of-range rungs, and incomplete chains fail before the service+touches stored streams.  Every warning enabled by the selected 'ValidationOptions' makes construction fail. This is intentionally stricter than a pure keiki use: events are keiro's@@ -52,6 +56,7 @@     defaultValidationOptions,     validateTransducer,  )+import Keiro.Codec qualified as Codec import Keiro.EventStream (EventStream (..), SnapshotPolicy (..), StateCodec (..)) import System.IO.Unsafe (unsafePerformIO) @@ -82,8 +87,9 @@ {- | Run keiki's pure umbrella check over a stream's transducer with the default options. This includes hidden-input, head recoverability, inversion ambiguity, guarded input reads, state-changing epsilon edges, determinism, and dead-edge-checks. An empty list means the stream passed every enabled check. Pure; no-solver.+checks, plus the event codec's schema and upcaster-chain construction+invariants. An empty list means the stream passed every enabled check. Pure;+no solver. -} validateEventStream ::     (Bounded s, Enum s, Ord s, Show s) =>@@ -106,7 +112,8 @@     EventStream (HsPred rs ci) rs s ci co ->     [EventStreamWarning] validateEventStreamWith opts label es =-    snapshotWarnings label es+    codecConfigWarnings label es+        <> snapshotWarnings label es         <> initialSnapshotEncodeWarnings label es         <> [ EventStreamWarning{eswStreamLabel = label, eswReason = renderWarning w}            | w <- validateTransducer (forceReplayContract opts) (transducer es)@@ -170,9 +177,10 @@                     <> show warns  {- | Wrap an 'EventStream' /without validation/. This skips every keiki and-keiro check, including the replay-contract checks that 'mkEventStream'-force-enables. A stream admitted through this function can silently lose state-changes and fail hydration. Tests and emergency forensics only; never use it+keiro check, including event-codec construction validation and the+replay-contract checks that 'mkEventStream' force-enables. A stream admitted+through this function can silently lose state changes, select the wrong+upcaster, or fail hydration. Tests and emergency forensics only; never use it for production streams. Prefer 'mkEventStream'. -} mkEventStreamUnchecked ::@@ -180,7 +188,45 @@     ValidatedEventStream phi rs s ci co mkEventStreamUnchecked = ValidatedEventStream -{- | Render a keiki warning to a human-readable reason. All eight constructors+codecConfigWarnings :: Text -> EventStream phi rs s ci co -> [EventStreamWarning]+codecConfigWarnings label es =+    case Codec.mkCodec (eventCodec es) of+        Right _ -> []+        Left err ->+            [ EventStreamWarning+                { eswStreamLabel = label+                , eswReason = "event codec misconfigured: " <> renderCodecConfigError err+                }+            ]++renderCodecConfigError :: Codec.CodecConfigError -> Text+renderCodecConfigError = \case+    Codec.CodecSchemaVersionInvalid version ->+        "schema version must be at least 1, got " <> showT version+    Codec.CodecDuplicateEventTypes eventTypes ->+        "duplicate event type tag(s): "+            <> Text.intercalate ", " [tag | Codec.EventType tag <- eventTypes]+    Codec.CodecDuplicateUpcasterSources versions ->+        "duplicate upcaster source version(s): "+            <> renderVersions versions+            <> "; only one rung may own each source version"+    Codec.CodecUpcasterSourceOutOfRange source target ->+        "upcaster source version "+            <> showT source+            <> " is outside the valid range 1.."+            <> showT (target - 1)+            <> " for target schema version "+            <> showT target+    Codec.CodecUpcasterChainIncomplete missing target ->+        "missing upcaster source version(s): "+            <> renderVersions missing+            <> "; stored payloads cannot reach target schema version "+            <> showT target+  where+    showT = Text.pack . show+    renderVersions = Text.intercalate ", " . map showT++{- | Render a keiki warning to a human-readable reason. Every constructor carry @tvwDetail@; the source vertex is @edgeSource . tvwEdge@ (or @tvwSource@ for pair warnings). -}@@ -202,6 +248,57 @@         "possibly-dead @" <> showT (edgeSource e) <> ": " <> Text.pack d     OpaqueGuard{tvwEdge = e, tvwDetail = d} ->         "opaque-guard @" <> showT (edgeSource e) <> ": " <> Text.pack d+    ProjectionResultUnsupported+        { tvwEdge = e+        , tvwProjectionPath = path+        , tvwProjectionShape = shape+        , tvwProjectionResultType = resultType+        , tvwDetail = d+        } ->+            "projection-result-unsupported @"+                <> showT (edgeSource e)+                <> " ["+                <> Text.pack path+                <> ", shape "+                <> Text.pack shape+                <> ", result "+                <> Text.pack resultType+                <> "]: "+                <> Text.pack d+    ProjectionOrderingUnsupported+        { tvwEdge = e+        , tvwProjectionPath = path+        , tvwProjectionShape = shape+        , tvwProjectionResultType = resultType+        , tvwDetail = d+        } ->+            "projection-ordering-unsupported @"+                <> showT (edgeSource e)+                <> " ["+                <> Text.pack path+                <> ", shape "+                <> Text.pack shape+                <> ", result "+                <> Text.pack resultType+                <> "]: "+                <> Text.pack d+    ProjectionOutsideGuard+        { tvwEdge = e+        , tvwProjectionPath = path+        , tvwProjectionShape = shape+        , tvwProjectionLocation = location+        , tvwDetail = d+        } ->+            "projection-outside-guard @"+                <> showT (edgeSource e)+                <> " ["+                <> Text.pack path+                <> ", shape "+                <> Text.pack shape+                <> ", location "+                <> Text.pack location+                <> "]: "+                <> Text.pack d   where     showT = Text.pack . show