packages feed

keiki (empty) → 0.1.0.0

raw patch · 57 files changed

+18484/−0 lines, 57 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, cryptohash-sha256, deepseq, hspec, keiki, nothunks, profunctors, sbv, template-haskell, text, time

Files

+ CHANGELOG.md view
@@ -0,0 +1,94 @@+# 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. Public surface stabilised around the+symbolic-register transducer formalism described in+`docs/research/synthesis-c-foundation-b-presentation-with-worked-examples.md`.++### Added++- `Keiki.Core` — the foundational `RegFile rs` register file, the+  `SymTransducer` GADT, and the slot / predicate / command / event /+  output algebra. Edges carry a *list-shaped* output+  (`output :: [OutTerm rs ci co]`) so one transition can emit+  zero, one, or N events in declaration order — a Generalized+  Sequential Machine, not a letter FST. The `InFlight s co`+  wrapper exposes the streaming-replay state for event-by-event+  replay through length-N edges; `applyEvent` (letter-only) and+  `applyEventStreaming` (InFlight-aware) cover the two regimes,+  while `applyEvents` does atomic chunk replay over command+  boundaries.+- `Keiki.Acceptor` — input- and output-side acceptor projections.+- `Keiki.Builder` — the monadic edge-authoring DSL.+- `Keiki.Composition` — sequential, alternative, and single-step+  feedback combinators on `SymTransducer`s.+- `Keiki.Decider` — the Chassaing-shape `Decider` facade+  (`decide` / `evolve` / `evolveStreaming` / `initialState` /+  `isTerminal`) derived mechanically from a `SymTransducer`.+  `decide` returns the full event list directly, including+  length-2+ chains from multi-event edges; `evolveStreaming`+  threads the `Keiki.Core.InFlight` wrapper through length-N+  edges for event-by-event streaming replay.+- `Keiki.Generics` — `RegFieldsOf`, `GRecord`, `mkInCtor` /+  `mkInCtorVia`, `mkWireCtor` / `mkWireCtorVia`, plus `EmptyRegFile`.+- `Keiki.Generics.TH` — `deriveAggregateCtors`, `deriveWireCtors`,+  `deriveView` for record-payload aggregates, plus zero-enumeration+  `*All` splices that retire the hand-typed+  `(constructorName, shortName)` spec list in the common case where+  the short name equals the constructor name:+  - `deriveAggregateCtorsAll ''Cmd ''Regs` — enumerates every command+    constructor and emits `inCtor<Ctor>` / `inp<Ctor>` / `is<Ctor>`+    (singletons omit `inp<Ctor>`), defaulting each short-name suffix to+    the constructor name.+  - `deriveWireCtorsAll ''Event` — the event-side dual, emitting+    `wire<Ctor>` plus, for record-payload events, the `<Ctor>TermFields`+    record and its `ToOutFields` instance.+  - `deriveAggregate ''Cmd ''Regs ''Event` — fuses both `*All` variants+    into one splice covering an aggregate's command and event+    constructors.+  The enumerated `deriveAggregateCtors` / `deriveWireCtors` remain for+  abbreviated short names that differ from the constructor name.+- `Keiki.NoThunks` — strict-evaluation discipline assertions for+  the register file and per-vertex state.+- `Keiki.Profunctor` — `Profunctor` / `Category` / `Strong` /+  `Choice` instances on the existential `SymTransducer` wrapper.+- `Keiki.Render.Mermaid` — Mermaid renderers for single and+  composite `SymTransducer` diagrams.+- **`Keiki.Shape`** — GHC-upgrade-safe shape hash for snapshot+  discrimination. `class CanonicalTypeName a`, `class+  KnownRegFileShape (rs :: [Slot])`, `regFileShapeHash`,+  `regFileShapeCanonical`, `renderStableTypeRep`, `sha256Hex`.+  Reusable by any codec; the optional JSON codec lives in the+  sibling package `keiki-codec-json`.+- `Keiki.Symbolic` — SBV-backed `sat` / `isBot` /+  `isSingleValuedSym` analyses for symbolic CI gating.++### Out of scope (intentional)++- No built-in serialization. JSON / CBOR / Protobuf codecs are+  runtime concerns and live in sibling packages — currently+  `keiki-codec-json`. The pure core talks only typed Haskell+  values; the shape hash discriminates snapshots regardless of+  codec choice.++### Validated against++- GHC 9.12.2 locally on macOS aarch64 and in CI on Ubuntu Linux+  x86_64 (see `.github/workflows/ci.yml`).+- 278 hspec assertions in the in-tree test suite, including 11+  `Keiki.ShapeSpec` golden assertions for the shape hash, 10+  `Keiki.CoreInFlightSpec` assertions for the GSM streaming+  replay path, and 3 `Keiki.CompositionMultiEventSpec`+  assertions for multi-event composition. The downstream+  `jitsurei` package adds 96 more assertions exercising eight+  worked-example aggregates against the public surface.
+ README.md view
@@ -0,0 +1,138 @@+# keiki — 継起++A Haskell library for the **pure core** of event sourcing, workflow+engines, and durable execution, built on one formalism: the+symbolic-register finite-state transducer.++keiki keeps the runtime boundary deliberately small. You describe an+aggregate or workflow once as a typed transducer; the library derives+the event-sourcing facade, replay, acceptors, projections, composition+machinery, diagram renderers, and optional symbolic checks from that+single declaration.++## The name++**継起** (*keiki*) is the Japanese word for **"successive occurrence"** —+events that follow, one after another, each rising out of what came before.++| Kanji | Reading | Meaning |+|---|---|---|+| 継 | *kei* | to continue, to succeed (as an heir does), to follow on |+| 起 | *ki*  | to rise, to occur, to begin, to happen |++The choice is literal. An event-sourced aggregate is a sequence of events+in succession, each one rising out of the state the previous events left+behind. *keiki* names that pattern directly: 継 (the prior event is+succeeded by) 起 (the next one rising). The replay fold —+`reconstitute :: [Event] → State` — is exactly the operation the word+describes.++(Disambiguation, since the romanisation is ambiguous: this is 継起, not+景気 *keiki* "economic conditions" nor 計器 *keiki* "gauge / instrument".+Only the 継起 reading carries the "succession of events" sense.)++## What it is++A unified treatment of three problems often solved with separate+runtime concepts:++1. **Event sourcing** — store the immutable log of events, replay to+   recover state.+2. **Workflow engines** — coordinate long-running multi-step processes.+3. **Durable execution** — resume cleanly after a crash, mid-process.++keiki models all three as **finite-state transducers** with a typed+register file and predicate-labelled guards: a practical hybrid of+Symbolic Finite Transducers and Streaming String Transducers. From one+`SymTransducer` declaration, the library mechanically derives:++- the Chassaing-shape `Decider` (`decide`/`evolve`/`initialState`/`isTerminal`),+- input- and output-side `Acceptor`s,+- per-vertex projections (the "B-presentation" view),+- composition (`compose`, `alternative`, `feedback1`),+- profunctor / `Category` / `Strong` / `Choice` instances,+- Mermaid and Markdown renderers for documentation,+- single-valuedness checks via SBV + z3 as an opt-in symbolic CI gate.++`delta` / `omega` / `applyEvent` use concrete predicate evaluation — no+solver in the per-event hot path. Solver dispatch is reserved for+build-time analysis.++## Status++Pre-1.0, prepared for the initial `0.1.0.0` Hackage release. The+planned v0.1 surface is implemented and validated against in-tree tests+plus the downstream `jitsurei` worked-example package.++The core package is intentionally codec-free. JSON support lives in+[`keiki-codec-json`](keiki-codec-json/README.md), and downstream codec+testing helpers live in+[`keiki-codec-json-test`](keiki-codec-json-test/README.md).++## Build++Requires GHC 9.12 and (for the symbolic analyses only) `z3` on `PATH`.++```sh+nix develop          # provides ghc 9.12, cabal, z3+cabal build all+cabal test all+```++Pure evaluation (`delta`, `omega`, `step`, `reconstitute`) does not+depend on z3. The symbolic checks in `Keiki.Symbolic` will fail loudly+if z3 is missing when invoked.++## A taste++The smallest useful aggregate, in full:++```haskell+emailDelivery+  :: SymTransducer (HsPred EmailRegs EmailCmd)+                   EmailRegs EmailVertex EmailCmd EmailEvent+emailDelivery = B.buildTransducer EmailPending emptyRegFile+                  (\case EmailSentVertex -> True; _ -> False) do+  B.from EmailPending do+    B.onCmd inCtorSendEmail $ \d -> B.do+      B.slot @"emailRecipient" .= d.recipient+      B.slot @"emailSubject"   .= d.subject+      B.slot @"emailSentAt"    .= d.at+      B.emit wireEmailSent EmailSentTermFields+        { recipient = d.recipient+        , subject   = d.subject+        , at        = d.at+        }+      B.goto EmailSentVertex+```++`Decider`, `Acceptor`, replay, and the per-vertex view are all derived+from this one declaration. See the sibling `jitsurei/` package for the+full worked aggregates the test suite drives.++## Repository documentation++The repository includes user guides, design notes, and implementation+history:++| Folder | Audience |+|---|---|+| `docs/foundations/` | Onboarding. Reads as a tutorial in ~1 hour; assumes Haskell, no automata-theory background. Start at `00-reading-guide.md`. |+| `docs/guide/` | Action-oriented. `user-guide.md` is the canonical authoring walkthrough; topical guides cover composition, profunctors, symbolic CI, AST drop-down, and B-views. |+| `docs/research/` | Design notes for the library itself. Assume foundations vocabulary. The current baseline is `synthesis-c-foundation-b-presentation-with-worked-examples.md`. |+| `docs/adr/` | Stable architecture decisions distilled from the plan history. |+| `docs/plans/` and `docs/masterplans/` | Execution records for the work that produced v0.1. |+| `docs/historical/` | Superseded design notes, retained for context only. |++For a status snapshot — what's implemented, what's next, and what's intentionally+out of scope — see [`ROADMAP.md`](ROADMAP.md).++Recommended shortest path:++1. `docs/foundations/00-reading-guide.md` — orientation.+2. `docs/guide/user-guide.md` — write your first aggregate.+3. `docs/research/synthesis-c-foundation-b-presentation-with-worked-examples.md` — the design baseline.++## License++BSD-3-Clause. See [`keiki.cabal`](keiki.cabal) for package metadata.
+ keiki.cabal view
@@ -0,0 +1,144 @@+cabal-version:   3.0+name:            keiki+version:         0.1.0.0+synopsis:        Pure core for symbolic-register transducer event sourcing.+description:+  A Haskell library for the pure core of event sourcing, workflow+  engines, and durable execution, built on the symbolic-register+  finite-state transducer formalism (a hybrid of Symbolic Finite+  Transducers and Streaming String Transducers).+  .+  Provides a typed register-file (@RegFile rs@), a deterministic+  transducer DSL with predicate-labelled guards, composition+  combinators (sequential, alternative, single-step feedback), a+  mechanically-derived @Decider@ facade, input- and output-side+  acceptors, generic Mermaid renderers, and a GHC-upgrade-safe+  shape hash (@Keiki.Shape@) for snapshot discrimination.+  .+  The library is intentionally codec-free: the pure layer talks+  only typed Haskell values. JSON serialisation lives in the+  sibling package @keiki-codec-json@; an opt-in test toolkit+  lives in @keiki-codec-json-test@.++license:         BSD-3-Clause+author:          Nadeem Bitar+maintainer:      nadeem@gmail.com+copyright:       2026 Nadeem Bitar+category:        Control+build-type:      Simple+tested-with:     GHC >=9.12 && <9.13+extra-doc-files:+  CHANGELOG.md+  README.md++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++-- The library's symbolic analyses (sat, isBot, isSingleValuedSym) are+-- backed by SBV and require the z3 SMT solver to be available in PATH+-- at runtime. Install via: brew install z3 (macOS) or apt install z3+-- (Debian). The library will fail loudly if z3 is missing when those+-- analyses run; pure evaluation (delta/omega/step/reconstitute) does+-- not depend on z3.++library+  import:          warnings, shared-extensions+  exposed-modules:+    Keiki.Acceptor+    Keiki.Builder+    Keiki.Composition+    Keiki.Core+    Keiki.Decider+    Keiki.Generics+    Keiki.Generics.TH+    Keiki.Internal.Slots+    Keiki.NoThunks+    Keiki.Operators+    Keiki.Profunctor+    Keiki.Render.Inspector+    Keiki.Render.Markdown+    Keiki.Render.Mermaid+    Keiki.Render.Pretty+    Keiki.Render.Validate+    Keiki.Shape+    Keiki.Symbolic++  hs-source-dirs:  src+  build-depends:+    , base               ^>=4.21+    , bytestring         ^>=0.12+    , containers         >=0.6   && <0.9+    , cryptohash-sha256  ^>=0.11+    , nothunks           >=0.3   && <0.4+    , profunctors        >=5.6   && <6+    , sbv                >=11.7  && <15+    , template-haskell   ^>=2.23+    , text               ^>=2.1+    , time               ^>=1.14++test-suite keiki-test+  import:         warnings, shared-extensions+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Spec.hs+  other-modules:+    Keiki.AcceptorSpec+    Keiki.ArrowSpec+    Keiki.BuilderSpec+    Keiki.BuilderSpike+    Keiki.CategorySpec+    Keiki.ChoiceSpec+    Keiki.CollectionSpike+    Keiki.CompositionAlternativeSpec+    Keiki.CompositionFeedback1Spec+    Keiki.CompositionMultiEventSpec+    Keiki.CompositionNarySpec+    Keiki.CompositionSpec+    Keiki.CoreApplyEventsSpec+    Keiki.CoreHiddenInputsGSMSpec+    Keiki.CoreInFlightSpec+    Keiki.CoreSpec+    Keiki.DeciderSpec+    Keiki.Fixtures.EmailDelivery+    Keiki.Fixtures.UserRegistration+    Keiki.Generics.THSpec+    Keiki.NoThunksSpec+    Keiki.OperatorsQualifiedSpec+    Keiki.OperatorsSpec+    Keiki.ProfunctorSpec+    Keiki.RecomputeVerifySpec+    Keiki.Render.InspectorSpec+    Keiki.Render.MarkdownSpec+    Keiki.Render.MermaidSpec+    Keiki.Render.PrettySpec+    Keiki.Render.ValidateSpec+    Keiki.ShapeSpec+    Keiki.StepEitherSpec+    Keiki.StrongSpec+    Keiki.SymbolicSpec+    Keiki.ValidationSpec++  build-depends:+    , base         ^>=4.21+    , containers   >=0.6   && <0.9+    , deepseq      ^>=1.5+    , hspec        ^>=2.11+    , keiki+    , nothunks     >=0.3   && <0.4+    , profunctors  >=5.6   && <6+    , sbv          >=11.7  && <15+    , text         ^>=2.1+    , time         ^>=1.14
+ src/Keiki/Acceptor.hs view
@@ -0,0 +1,159 @@+-- | First-class projections of a 'SymTransducer' onto one alphabet+-- at a time.+--+-- The foundations chapter+-- @docs/foundations/04-projections-and-deriving-event-sourcing.md@+-- spells out the central insight that any FST has two acceptor+-- projections:+--+-- * The /input projection/ π₁ — drop the events. The remaining+--   transition function is an acceptor over commands. Its language+--   is the set of command sequences the aggregate accepts.+-- * The /output projection/ π₂ — drop the commands by inverting ω.+--   The remaining transition function is @evolve@ (the+--   event-language acceptor). Its language is the set of event+--   sequences the aggregate could have produced — the set of+--   replayable logs.+--+-- In 'Keiki.Core' these projections are /implicit/: π₁ is+-- 'Keiki.Core.delta'; π₂ is 'Keiki.Core.applyEvent'. This module+-- /names/ them as a first-class data type so downstream code (UI,+-- validation, generated documentation) can pattern-match on a known+-- shape instead of plumbing the step functions by hand.+--+-- == Quick reference+--+-- @+-- accepts (inputAcceptor t)  cmds   :: Bool   -- "is this command sequence in the input language?"+-- accepts (outputAcceptor t) events :: Bool   -- "is this event sequence in the output language?"+-- @+--+-- See @docs/research/acceptor-projections-design.md@ for the design+-- record (deferred scope, why the state carrier is+-- @(s, 'Keiki.Core.RegFile' rs)@, relationship to 'Keiki.Decider').+module Keiki.Acceptor+  ( -- * The acceptor projection+    Acceptor (..),++    -- * Projecting a transducer+    inputAcceptor,+    outputAcceptor,++    -- * Folding helpers+    runAcceptor,+    accepts,+  )+where++import Keiki.Core+  ( BoolAlg,+    RegFile,+    SymTransducer (..),+    applyEvent,+    delta,+  )++-- | A minimal acceptor over alphabet @a@ with state carrier @s@.+--+-- The three fields are the membership question reduced to its+-- essence:+--+-- * @aStep@ — single-step transition. 'Just' on a successful step;+--   'Nothing' to reject (the absence of a transition /is/ rejection).+-- * @aInitial@ — the start state.+-- * @aIsFinal@ — final-state predicate. A run accepts iff it+--   terminates in a state for which this predicate holds.+--+-- The richer return type of 'Keiki.Core.delta' /+-- 'Keiki.Core.applyEvent' (which thread an updated 'RegFile') is+-- preserved by the projections in this module by hiding the register+-- file inside @s@; see 'inputAcceptor' / 'outputAcceptor'.+--+-- 'Acceptor' carries closures and therefore has no 'Show' or 'Eq'+-- instance; assert on 'runAcceptor' or 'accepts' results instead.+data Acceptor a s = Acceptor+  { aStep :: s -> a -> Maybe s,+    aInitial :: s,+    aIsFinal :: s -> Bool+  }++-- | Project a 'SymTransducer' to its /input/ acceptor (π₁): the+-- acceptor over the command alphabet whose step is+-- 'Keiki.Core.delta'.+--+-- The state carrier is @(s, 'RegFile' rs)@ because edge guards+-- depend on the register file as well as the control vertex.+-- 'aIsFinal' ignores the register file and consults+-- @'isFinal' t@.+--+-- @+-- accepts (inputAcceptor t) cmds  ==  True+-- @+--+-- iff successively applying 'Keiki.Core.delta' to each command+-- reaches a final control vertex. A command sequence is rejected+-- (returns 'False') as soon as any step finds zero or multiple+-- satisfied outgoing edges.+inputAcceptor ::+  (BoolAlg phi (RegFile rs, ci)) =>+  SymTransducer phi rs s ci co ->+  Acceptor ci (s, RegFile rs)+inputAcceptor t =+  Acceptor+    { aStep = \(s, regs) ci -> delta t s regs ci,+      aInitial = (initial t, initialRegs t),+      aIsFinal = \(s, _regs) -> isFinal t s+    }++-- | Project a 'SymTransducer' to its /output/ acceptor (π₂): the+-- acceptor over the event alphabet whose step is+-- 'Keiki.Core.applyEvent'.+--+-- The state carrier is @(s, 'RegFile' rs)@ because 'applyEvent'+-- itself threads the register file through replay.+--+-- @+-- accepts (outputAcceptor t) events  ==  True+-- @+--+-- iff successively applying 'Keiki.Core.applyEvent' to each event+-- reaches a final control vertex — equivalently, iff+-- @'Keiki.Core.reconstitute' t events@ returns 'Just' a final+-- @(s, regs)@. The output acceptor /is/ the @evolve@ acceptor the+-- foundations chapter derives.+outputAcceptor ::+  (BoolAlg phi (RegFile rs, ci), Eq co) =>+  SymTransducer phi rs s ci co ->+  Acceptor co (s, RegFile rs)+outputAcceptor t =+  Acceptor+    { aStep = \(s, regs) co -> applyEvent t s regs co,+      aInitial = (initial t, initialRegs t),+      aIsFinal = \(s, _regs) -> isFinal t s+    }++-- | Run an 'Acceptor' over a sequence. Returns 'Just' the terminal+-- state if every step succeeds, 'Nothing' on the first step that+-- rejects.+--+-- @runAcceptor a@ is @'foldlM' ('aStep' a) ('aInitial' a)@ written+-- longhand; the loose form keeps the import surface minimal and the+-- haddock close to the operational semantics.+runAcceptor :: Acceptor a s -> [a] -> Maybe s+runAcceptor a = go (aInitial a)+  where+    go s [] = Just s+    go s (x : xs) = aStep a s x >>= \s' -> go s' xs++-- | Decide membership: 'True' iff the input is accepted (every step+-- succeeds and the terminal state is final).+--+-- @+-- accepts a xs == case runAcceptor a xs of+--   Just s  -> aIsFinal a s+--   Nothing -> False+-- @+accepts :: Acceptor a s -> [a] -> Bool+accepts a xs = case runAcceptor a xs of+  Just s -> aIsFinal a s+  Nothing -> False
+ src/Keiki/Builder.hs view
@@ -0,0 +1,822 @@+-- 'Disjoint' on '(.=)' is the static check itself; GHC otherwise warns.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | A monadic edge-builder DSL for authoring 'SymTransducer's. The+-- builder is purely additive on top of "Keiki.Core": every edge it+-- produces is a value of the existing 'Keiki.Core.Edge' type, and+-- the resulting 'Keiki.Core.SymTransducer' is consumed unchanged by+-- "Keiki.Acceptor", "Keiki.Composition", "Keiki.Decider",+-- "Keiki.Symbolic", and the example-side specs.+--+-- == Why a builder+--+-- A hand-written transducer in the AST surface needs four nested+-- pieces of boilerplate per edge: the 'Edge' record literal, an+-- @'IndexN' \"name\" Regs T@ annotation on every register write, an+-- infix @\`combine\`@ chain stitching the writes together, and an+-- @'OFCons' … 'OFNil'@ chain (plus a 'pack' prefix and a 'Just'+-- wrapper) describing the output. The builder collapses each piece:+--+--   * 'buildTransducer' assembles a 'SymTransducer' from a+--     'VertexBuilder' and three scalar arguments (initial vertex,+--     initial register file, finality predicate).+--   * 'from' tags one source vertex; 'onCmd' / 'onEpsilon' add one+--     edge each.+--   * '(.=)' adds one register write to the edge under construction.+--     The slot name flows through a type-level @(w :: [Symbol])@+--     index so that a duplicated @'(.=)'@ to the same slot fails to+--     type-check at the offending line.+--   * 'emit' takes a 'WireCtor' and a per-event+--     @\<CtorName\>TermFields rs ci@ record (emitted by+--     'Keiki.Generics.TH.deriveWireCtors'); fields read top-to-+--     bottom keyed by the wire side's payload field names. The+--     'InCtor' is recovered from the enclosing 'onCmd'; the lower-+--     level operator-form @(t1 *: t2 *: oNil)@ remains available+--     as an escape hatch via the same overload.+--+-- See @docs\/research\/edge-builder-dsl-shape.md@ for the full+-- design and per-question rationale (carrier monad,+-- distinct-targets enforcement, 'goto' termination semantics, etc).+--+-- == Worked example: the EmailDelivery aggregate+--+-- @+-- import qualified Keiki.Builder as B+-- import Keiki.Builder        ((.=))+-- import qualified Prelude+--+-- emailDelivery+--   :: 'Keiki.Core.SymTransducer' ('Keiki.Core.HsPred' EmailRegs EmailCmd)+--                                  EmailRegs EmailVertex+--                                  EmailCmd EmailEvent+-- emailDelivery = B.'buildTransducer' EmailPending emptyEmailRegs+--                   (\\case EmailSentVertex -> True; _ -> False)+--                   $ Prelude.do        -- VertexBuilder is a plain Monad+--+--     B.'from' EmailPending Prelude.do  -- EdgeListBuilder is plain+--       B.'onCmd' inCtorSendEmail $ \\d -> B.do  -- EdgeBuilder is indexed+--         B.'slot' \@\"emailRecipient\" .= d.recipient+--         B.'slot' \@\"emailSubject\"   .= d.subject+--         B.'slot' \@\"emailSentAt\"    .= d.at+--         B.'emit' wireEmailSent EmailSentTermFields+--           { recipient = d.recipient+--           , subject   = d.subject+--           , at        = d.at+--           }+--         B.'goto' EmailSentVertex+--+--     B.'from' EmailSentVertex (Prelude.pure ())  -- terminal+-- @+--+-- The user's aggregate module needs three pragmas / imports:+--+--   * @{-\# LANGUAGE QualifiedDo \#-}@ — so @B.do@ resolves to this+--     module's indexed bind.+--   * @{-\# LANGUAGE BlockArguments \#-}@ — so a @B.do@ block can+--     appear as a function argument without parentheses.+--   * @import qualified Keiki.Builder as B@ /and/+--     @import Keiki.Builder ((.=))@ — the operator must be in scope+--     unqualified; @B.(.=)@ is unreadable.+--+-- The @\<CtorName\>TermFields@ record (e.g. @EmailSentTermFields@)+-- is generated by 'Keiki.Generics.TH.deriveWireCtors' alongside the+-- existing @wire\<CtorName\>@ value. For ad-hoc cases that do not+-- correspond to a single event ctor, the lower-level operator sugar+-- '(*:)' / 'oNil' (re-exports of 'Keiki.Core.OFCons' /+-- 'Keiki.Core.OFNil') builds the 'OutFields' HList directly:+--+-- @+-- B.'emit' wireEmailSent (d.recipient *: d.subject *: d.at *: B.'oNil')+-- @+--+-- Both shapes resolve through the 'ToOutFields' typeclass; both+-- produce the same 'Keiki.Core.OPack' AST node.+--+-- == Three-layer monad shape+--+-- Three carriers, only the innermost is indexed:+--+--   1. 'VertexBuilder' (plain 'Monad') — the top-level. State is+--      a list @[(v, [Edge ...])]@; 'from' writes one entry.+--   2. 'EdgeListBuilder' (plain 'Monad') — the per-source-vertex+--      layer. State is the list of edges out of that vertex;+--      'onCmd' \/ 'onEpsilon' each prepend one.+--   3. 'EdgeBuilder' (indexed) — the per-edge body. Type-level+--      @(w :: [Symbol])@ tracks the slots written so far; '(.=)'+--      extends @w@ and inherits a 'Disjoint'-driven static check.+--+-- The 'QualifiedDo' machinery only re-binds @(>>=)@/@(>>)@ for the+-- innermost layer; the outer two use 'Prelude.do'.+--+-- == Misuse diagnostics+--+-- * Duplicate '(.=)' to the same slot: caught at compile time via+--   the 'Keiki.Internal.Slots.Disjoint' 'GHC.TypeError.TypeError',+--   which names the duplicated slot.+--+-- * Missing 'goto': caught at finalize time (when 'buildTransducer'+--   evaluates the 'VertexBuilder' do-block) with a runtime error+--   naming the source vertex and edge index.+--+-- * Multiple 'goto's in the same edge body: caught the same way.+--+-- == When to drop down to the AST+--+-- Use the AST directly when:+--+--   * The aggregate has bespoke guard logic the builder does not+--     express (a hand-built 'HsPred' tree the builder cannot+--     accumulate via 'requireEq' / 'requireGuard').+--   * The aggregate composes 'Edge' values from helper functions+--     defined elsewhere (the builder is meant to /author/ edges, not+--     to be a pluggable assembly tool).+--+-- Both directions can coexist in one module: the builder produces+-- @'SymTransducer'@s of the same type the AST does, and+-- "Keiki.Composition" 'Keiki.Composition.compose' takes the+-- builder-produced values without modification.+module Keiki.Builder+  ( -- * Top-level entry point+    buildTransducer,++    -- * Vertex-level builder+    VertexBuilder,+    from,++    -- * Edge-list builder (per source vertex)+    EdgeListBuilder,+    onCmd,+    onEpsilon,++    -- * Edge body builder (per outgoing transition)+    EdgeBuilder,++    -- ** Slot writes+    slot,+    (.=),+    (=:),+    reg,++    -- ** Outputs+    emit,+    emitWith,+    noEmit,++    -- ** Output-fields HList sugar+    (*:),+    oNil,++    -- ** Field-keyed record sugar+    ToOutFields (..),++    -- ** Guards+    requireEq,+    requireGuard,+    Cmp (..),+    requireCmp,+    requireLt,+    requireLe,+    requireGt,+    requireGe,++    -- ** Termination+    goto,++    -- ** Payload projection (OverloadedRecordDot)+    PayloadProj,++    -- * QualifiedDo bind/return exports+    -- $qualifiedDo+    (>>=),+    (>>),+    pure,+    return,+  )+where++import Data.Typeable (Typeable)+import GHC.Records (HasField (..))+import GHC.TypeLits (KnownSymbol, Symbol)+import Keiki.Core+  ( Cmp (..),+    Edge (..),+    HsPred (..),+    InCtor,+    Index,+    OutFields (..),+    OutTerm,+    RegFile,+    SymTransducer (..),+    Term (TReg),+    Update (..),+    WireCtor,+    combine,+    inpCtor,+    matchInCtor,+    oNil,+    pack,+    (*:),+  )+import Keiki.Core qualified as K+import Keiki.Internal.Slots+  ( Concat,+    Disjoint,+    HasIndexN (..),+    IndexN (..),+  )+import Unsafe.Coerce (unsafeCoerce)+import Prelude hiding (pure, return, (>>), (>>=))+import Prelude qualified++-- $qualifiedDo+--+-- @QualifiedDo@ desugars @B.do { … }@ to @B.>>=@, @B.>>@, @B.pure@,+-- @B.return@. These exports are the indexed analogues that thread+-- the type-level slot-set through every edge-body step. They are+-- not the right operators for the outer 'VertexBuilder' /+-- 'EdgeListBuilder' layers — those use the regular 'Prelude.do'+-- syntax with the 'Monad' instances declared below.++-- * The per-edge state ----------------------------------------------------++-- | The growing edge state inside an 'EdgeBuilder' body. Lifecycle:+-- 'onCmd' / 'onEpsilon' construct an initial 'PartialEdge' (with+-- 'PTop' or @'matchInCtor' ic@ as guard, 'UKeep' as update, no+-- output, no targets); each step in the body modifies one or more+-- fields; 'finalizeEdge' validates that exactly one 'goto' was+-- called and packages the result into a closed 'Edge'. The+-- existential @w@ on 'Edge''s 'update' field closes here.+data PartialEdge rs ci co v (w :: [Symbol]) = PartialEdge+  { peGuard :: HsPred rs ci,+    peUpdate :: Update rs w ci,+    -- | Output terms accumulated by 'emit' / 'emitWith' calls in+    -- declaration order (snoc-appended). The empty list is an ε-edge+    -- (@output = []@ on the resulting 'Edge'); a single 'emit' yields+    -- a length-1 list (today's letter behaviour); two or more 'emit's+    -- in one body yield a multi-event edge (EP-19).+    peOutput :: [OutTerm rs ci co],+    -- | Reverse-order list of every 'goto' invocation in the body.+    -- Finalization requires exactly one element.+    peTargets :: [v],+    -- | The 'InCtor' bound by the enclosing 'onCmd', so that the+    -- 2-argument 'emit' can recover it without the user repeating+    -- it. 'Nothing' inside an 'onEpsilon' body — 'emit' there must+    -- use 'emitWith' to supply the 'InCtor' explicitly.+    peInCtor :: Maybe (PeInCtor ci)+  }++-- | Existential wrapper hiding the @ifs@ slot list of an 'InCtor'.+-- Stored on 'PartialEdge' by 'onCmd' and read back by 'emit'.+--+-- This is a builder-local existential rather than a reuse of+-- 'Keiki.Symbolic.SomeInCtor' because the latter carries an+-- 'ExtractRegFile' constraint the builder does not need and lives+-- in a module that pulls SBV; reusing it would add an SBV edge to+-- every consumer of "Keiki.Builder".+data PeInCtor ci where+  PeInCtor :: InCtor ci ifs -> PeInCtor ci++-- | The per-edge indexed-state monad. The two phantom slot-set+-- indices @(w :: [Symbol])@ (before this step) and @(w' :: [Symbol])@+-- (after this step) make every '(.=)' visible to the type system,+-- so a duplicated @'(.=)'@ to the same slot fails at the offending+-- line via the 'Keiki.Internal.Slots.Disjoint' constraint that+-- 'Keiki.Core.combine' carries.+--+-- Functor / Applicative / Monad instances are not provided because+-- they would be 'IxFunctor' / 'IxApplicative' / 'IxMonad' (the+-- type-level slot-set changes between operand and result), which+-- requires a separate type-class hierarchy. Instead, this module+-- exports its own @(>>=)@ / @(>>)@ / 'pure' / 'return' for use+-- with @QualifiedDo@.+newtype EdgeBuilder rs ci co v (w :: [Symbol]) (w' :: [Symbol]) a+  = EdgeBuilder+  { runEdgeBuilder ::+      PartialEdge rs ci co v w ->+      (a, PartialEdge rs ci co v w')+  }++-- * QualifiedDo bind/return exports ----------------------------------------++-- | Indexed bind. The @w@ index of the first argument flows through+-- the second argument's @w@ argument, and the second argument's @w'@+-- index becomes the result's @w'@. Re-export for @QualifiedDo@.+(>>=) ::+  EdgeBuilder rs ci co v w1 w2 a ->+  (a -> EdgeBuilder rs ci co v w2 w3 b) ->+  EdgeBuilder rs ci co v w1 w3 b+EdgeBuilder f >>= k = EdgeBuilder $ \pe ->+  let (a, pe1) = f pe+      EdgeBuilder g = k a+   in g pe1++infixl 1 >>=++-- | Sequence. Defined in terms of '(>>=)'.+(>>) ::+  EdgeBuilder rs ci co v w1 w2 a ->+  EdgeBuilder rs ci co v w2 w3 b ->+  EdgeBuilder rs ci co v w1 w3 b+m >> n = m Keiki.Builder.>>= \_ -> n++infixl 1 >>++-- | Embed a value. Slot-set unchanged.+pure :: a -> EdgeBuilder rs ci co v w w a+pure a = EdgeBuilder $ \pe -> (a, pe)++-- | Synonym for 'pure'. Re-exported for @QualifiedDo@.+return :: a -> EdgeBuilder rs ci co v w w a+return = Keiki.Builder.pure++-- * Slot writes ----------------------------------------------------------++-- | Lift a slot name (supplied via @TypeApplication@) to its+-- slot-name-tagged register index. Use with '(.=)':+--+-- > slot @"emailRecipient" .= d.recipient+--+-- == Why @slot \@\"name\"@ instead of @\#name@+--+-- The @\#name@ overloaded-label syntax tries to resolve+-- @IsLabel \"name\" (IndexN s rs r)@ against the instance head+-- @IsLabel s (IndexN s rs r)@. GHC will not commit to @s ~ \"name\"@+-- when @name@ is a quantified type variable in the enclosing+-- operator's signature (the pattern-side @s@ appears at two+-- positions in the constraint head; without an explicit annotation,+-- GHC defers commitment). 'slot' pins the symbol via TypeApplication+-- so the inference proceeds without ambiguity. Slot name still+-- appears once.+slot ::+  forall (name :: Symbol) rs r.+  (KnownSymbol name, HasIndexN name rs r) =>+  IndexN name rs r+slot = indexN @name @rs @r++-- | Read a register slot into a 'Keiki.Core.Term', the read-side+-- mirror of 'slot'. The slot name is supplied via @TypeApplication@,+-- so @reg \@\"appCreditScore\"@ needs no @:: 'Keiki.Core.Index' Regs+-- Ty@ annotation:+--+-- > approvalGuard = reg \@\"appCreditScore\" .>= lit 650+--+-- == When to use @reg \@\"name\"@ versus @\#name@+--+-- A bare overloaded label @\#name@ already resolves to a register-read+-- 'Keiki.Core.Term' through the @'GHC.OverloadedLabels.IsLabel' s+-- ('Keiki.Core.Term' rs ci r)@ instance, and is the lighter form+-- wherever GHC can infer the slot list @rs@ and value type @r@ — for+-- example the right-hand side of '(.=)', or an argument of+-- 'Keiki.Core.TApp1'. In positions where inference fails — notably a+-- hand-written guard conjunction, or an 'OutFields' element — @\#name@+-- needs the verbose @'Keiki.Core.proj' (\#name :: 'Keiki.Core.Index'+-- Regs Ty)@ annotation. 'reg' removes exactly that annotation by+-- pinning the name with a type application, the same way 'slot' does on+-- the write side. A consumer whose prelude re-exports @generic-lens@+-- (which ships its own @IsLabel@ instance that shadows keiki's) loses+-- the bare-@\#name@ read path entirely; because 'reg' goes through a+-- type application rather than an overloaded label, it is unaffected.+reg ::+  forall (name :: Symbol) rs ci ifs r.+  (KnownSymbol name, HasIndexN name rs r) =>+  Term rs ci ifs r+reg = TReg (indexNToIndex (indexN @name @rs @r))++-- | Slot assignment. The slot name is supplied by 'slot' (via+-- TypeApplication); the value is a 'Term'. The+-- @'Disjoint' '[name] w@ constraint inherits the type-level+-- distinct-targets check from 'Keiki.Core.combine': a duplicated+-- @'(.=)'@ to the same slot fails to type-check at the offending+-- line, with the existing 'Keiki.Internal.Slots.Disjoint'+-- 'GHC.TypeError.TypeError' naming the slot.+--+-- The RHS is a 'Term' (not a bare value); use+-- 'Keiki.Core.lit' / 'Keiki.Core.proj' / 'Keiki.Core.inpCtor' or+-- @d.fieldName@ via 'PayloadProj' to construct it.+(.=) ::+  forall name r rs ci ifs co v w.+  (KnownSymbol name, Disjoint '[name] w) =>+  IndexN name rs r ->+  Term rs ci ifs r ->+  EdgeBuilder rs ci co v w (Concat '[name] w) ()+ix .= t = EdgeBuilder $ \pe ->+  ((), pe {peUpdate = USet ix t `combine` peUpdate pe})++infixr 6 .=++-- | Slot assignment, an exact synonym for '(.=)': @slot \@\"x\" =: t@+-- is @slot \@\"x\" .= t@ and produces the identical 'Keiki.Core.Update'.+-- It exists for one reason — to dodge the name clash with+-- @Control.Lens.(.=)@. A module that authors edges /and/ imports+-- "Control.Lens" would otherwise need @import Control.Lens hiding+-- ((.=))@; with '(=:)' it can keep both imports unqualified and use+-- '(=:)' for slot writes. Modules that do not import "Control.Lens"+-- should keep using '(.=)', which matches the @.=@ spelling of @aeson@+-- \/ @lens@ \/ @mtl@. (A colon-prefixed @:=@ is not available: GHC+-- reserves operators beginning with a colon for data constructors, so a+-- value-level synonym must start with another symbol — hence @=:@.)+(=:) ::+  forall name r rs ci ifs co v w.+  (KnownSymbol name, Disjoint '[name] w) =>+  IndexN name rs r ->+  Term rs ci ifs r ->+  EdgeBuilder rs ci co v w (Concat '[name] w) ()+(=:) = (.=)++infixr 6 =:++-- * Termination -----------------------------------------------------------++-- | Set the edge's target vertex. Required exactly once per edge+-- body; missing 'goto' produces a finalize-time runtime error+-- naming the source vertex and edge index, and so does multiple+-- 'goto's in the same body.+goto :: v -> EdgeBuilder rs ci co v w w ()+goto v = EdgeBuilder $ \pe ->+  ((), pe {peTargets = v : peTargets pe})++-- * Outputs ---------------------------------------------------------------++-- | Emit an event. Takes the wire-side 'WireCtor' and an output+-- description that resolves to an 'OutFields' via 'ToOutFields' —+-- either a per-event @\<CtorName\>TermFields rs ci@ record (emitted+-- by 'Keiki.Generics.TH.deriveWireCtors') or a bare 'OutFields'+-- HList constructed with '(*:)' / 'oNil'. The input-side 'InCtor'+-- is recovered from the enclosing 'onCmd'; an 'emit' inside+-- 'onEpsilon' (where no 'InCtor' is bound) raises a finalize-time+-- error directing the user to 'emitWith'.+--+-- == Multi-event commands (EP-19)+--+-- Each 'emit' call snoc-appends one 'OutTerm' to the edge's output+-- list. A single 'emit' in the body produces a letter edge+-- (@output = [o]@); two or more 'emit's in the same body produce a+-- multi-event edge (@output = [o1, o2, ...]@) whose semantics is+-- documented at 'Keiki.Core.Edge'. The 'OutTerm's evaluate against+-- the same pre-transition @(regs, ci)@ snapshot; register updates+-- accumulated by '(.=)' apply once at the edge level, not per+-- emitted event.+emit ::+  forall co fs rs ci ifs v w rec.+  (ToOutFields rec rs ci ifs fs) =>+  WireCtor co fs ->+  rec ->+  EdgeBuilder rs ci co v w w ()+emit wc rec = EdgeBuilder $ \pe -> case peInCtor pe of+  Just (PeInCtor ic) ->+    -- 'onCmd' pins the same 'InCtor' into 'peInCtor' /and/ into the+    -- 'PayloadProj' the body projects through, so the record's input+    -- field schema 'ifs' (from 'ToOutFields') equals the pinned+    -- 'InCtor''s schema. The existential 'PeInCtor' hides that+    -- equality; 'reIndexPinnedInCtor' re-establishes it. This does not+    -- weaken replay soundness: the resulting 'OPack''s 'InCtor' and+    -- 'OutFields' share 'ifs', so 'solveOutput' recovers fields with no+    -- coercion (EP-53). Mirrors 'Keiki.Composition.unsafeCoerceInCtor'.+    ( (),+      pe+        { peOutput =+            peOutput pe+              ++ [pack (reIndexPinnedInCtor @ci @_ @ifs ic) wc (toOutFields rec)]+        }+    )+  Nothing ->+    error+      "Keiki.Builder.emit: no enclosing onCmd pinned an InCtor. \+      \Use 'emitWith ic wc fs' inside 'onEpsilon', or move the \+      \emit inside an 'onCmd' block."++-- | Re-establish the (existentially hidden) equality between a pinned+-- 'InCtor''s field schema and the schema the enclosing 'onCmd''s+-- 'PayloadProj' exposes. Unsound in general; justified at the single+-- 'emit' call site by 'onCmd' storing one and the same 'InCtor' in both+-- places (see 'emit'). The runtime representation is identical.+reIndexPinnedInCtor :: forall ci ifs0 ifs. InCtor ci ifs0 -> InCtor ci ifs+reIndexPinnedInCtor = unsafeCoerce++-- | Emit an event with an explicit 'InCtor'. The escape hatch for+-- 'onEpsilon' bodies (which do not pin an 'InCtor') and for any+-- caller that needs to override the one bound by the enclosing+-- 'onCmd'. Inside 'onCmd' the InCtor-less 'emit' is preferred.+-- Like 'emit', accumulates into the edge's output list — multiple+-- calls produce a multi-event edge.+emitWith ::+  forall co fs rs ci v w ifs rec.+  (ToOutFields rec rs ci ifs fs) =>+  InCtor ci ifs ->+  WireCtor co fs ->+  rec ->+  EdgeBuilder rs ci co v w w ()+emitWith ic wc rec = EdgeBuilder $ \pe ->+  ((), pe {peOutput = peOutput pe ++ [pack ic wc (toOutFields rec)]})++-- | Mark the edge as ε-output (no event). Idempotent: an edge with+-- no 'emit' or 'noEmit' call is also an ε-edge by default; 'noEmit'+-- exists only so the user can be explicit about intent. Mixing+-- 'noEmit' and 'emit' in the same body is allowed but the 'noEmit'+-- is a documentation no-op (the 'emit's still produce a non-empty+-- output list).+noEmit :: EdgeBuilder rs ci co v w w ()+noEmit = EdgeBuilder $ \pe -> ((), pe)++-- * Field-keyed record sugar ---------------------------------------------++-- | Convert a value of any type bearing the wire-side fields of an+-- event to the 'OutFields' HList that 'pack' (and therefore 'OPack')+-- consumes.+--+-- Two kinds of inhabitant matter:+--+--   * The TH-emitted per-event record type+--     @\<CtorName\>TermFields rs ci@ (one record per event ctor in+--     'Keiki.Generics.TH.deriveWireCtors''s spec list). Its fields+--     are 'Term'-typed mirrors of the payload's fields, so call+--     sites read top-to-bottom keyed by name.+--+--   * The bare 'OutFields' value built with '(*:)' \/ 'oNil', for+--     which the passthrough instance (id) makes the same 'B.emit'+--     overload accept the operator form unchanged.+--+-- The functional dependency @rec -> rs ci fs@ ensures a record type+-- uniquely determines all of @rs@, @ci@, and @fs@, so type+-- inference at call sites is local: GHC propagates them from the+-- record's type alone.+class ToOutFields rec rs ci ifs fs | rec -> rs ci ifs fs where+  toOutFields :: rec -> OutFields rs ci ifs fs++-- | Passthrough: a bare 'OutFields' is its own conversion. Lets+-- 'B.emit' accept either a per-event record or an+-- @(t1 *: t2 *: oNil)@ chain through the same overload.+instance ToOutFields (OutFields rs ci ifs fs) rs ci ifs fs where+  toOutFields = id++-- * Guards ----------------------------------------------------------------++-- | Conjoin an arbitrary 'HsPred' with the edge's existing guard.+-- Use this when the structural sugar of 'requireEq' is not enough+-- (e.g. for negated predicates, disjunctions, or guards constructed+-- by helper functions).+requireGuard :: HsPred rs ci -> EdgeBuilder rs ci co v w w ()+requireGuard p = EdgeBuilder $ \pe ->+  ((), pe {peGuard = PAnd (peGuard pe) p})++-- | Conjoin an equality predicate (@a '==' b@) with the edge's+-- existing guard.+requireEq ::+  (Eq r, Typeable r) =>+  Term rs ci ifs1 r ->+  Term rs ci ifs2 r ->+  EdgeBuilder rs ci co v w w ()+requireEq a b = requireGuard (PEq a b)++-- | Conjoin an ordering predicate (@a `op` b@ for the relation named+-- by 'Cmp') with the edge's existing guard. Unlike a threshold lifted+-- through 'Keiki.Core.TApp1'\/'TApp2', a 'PCmp' guard is structural and+-- visible to the SBV-backed analyses. The four direction-specific+-- conveniences 'requireLt'\/'requireLe'\/'requireGt'\/'requireGe' wrap+-- this with a fixed 'Cmp'.+requireCmp ::+  (Ord r, Typeable r) =>+  Cmp ->+  Term rs ci ifs1 r ->+  Term rs ci ifs2 r ->+  EdgeBuilder rs ci co v w w ()+requireCmp op a b = requireGuard (PCmp op a b)++-- | Require @a < b@. See 'requireCmp'.+requireLt,+  requireLe,+  requireGt,+  requireGe ::+    (Ord r, Typeable r) =>+    Term rs ci ifs1 r ->+    Term rs ci ifs2 r ->+    EdgeBuilder rs ci co v w w ()+requireLt = requireCmp CmpLt+requireLe = requireCmp CmpLe+requireGt = requireCmp CmpGt+requireGe = requireCmp CmpGe++-- * Payload projection ----------------------------------------------------++-- | An opaque wrapper around an 'InCtor' that lets the user project+-- the input symbol's fields via 'OverloadedRecordDot' inside an+-- 'onCmd' body. The 'HasField' instance translates @d.fieldName@ to+-- @inpCtor ic (indexN \@fieldName \@ifs \@r)@.+--+-- 'PayloadProj' has no record selectors of its own so the user's+-- @d.fieldName@ never collides with a built-in selector.+data PayloadProj rs ci ifs = PayloadProj (InCtor ci ifs)++-- | OverloadedRecordDot resolution: @d.fieldName@ on a 'PayloadProj'+-- builds a 'TInpCtorField' term that projects the named field of the+-- input symbol's payload.+instance+  (HasIndexN name ifs r) =>+  HasField name (PayloadProj rs ci ifs) (Term rs ci ifs r)+  where+  getField (PayloadProj ic) =+    inpCtor ic (indexNToIndex (indexN @name @ifs @r))++-- | Translate the slot-name-tagged 'IndexN' into the legacy+-- existentially-typed 'Index' that 'Keiki.Core.inpCtor' expects.+-- Both indices have the same runtime structure; the translation is+-- a structural recursion. (M3+ may widen 'inpCtor' to take 'IndexN'+-- directly; this helper keeps the spike's legacy bridge.)+indexNToIndex :: forall name rs r. IndexN name rs r -> Index rs r+indexNToIndex IZ = K.ZIdx+indexNToIndex (IS i) = K.SIdx (indexNToIndex i)++-- * Edge-list builder -----------------------------------------------------++-- | Per-source-vertex builder. Accumulates the list of outgoing+-- edges for the @from@-scope's vertex; each 'onCmd' / 'onEpsilon'+-- call prepends one edge (the list is reversed in 'from' before+-- storage so declaration order is preserved).+newtype EdgeListBuilder rs ci co v a = EdgeListBuilder+  { runEdgeListBuilder ::+      v ->+      [Edge (HsPred rs ci) rs ci co v] ->+      (a, [Edge (HsPred rs ci) rs ci co v])+  }++instance Functor (EdgeListBuilder rs ci co v) where+  fmap f (EdgeListBuilder k) = EdgeListBuilder $ \src acc ->+    let (a, acc') = k src acc in (f a, acc')++instance Applicative (EdgeListBuilder rs ci co v) where+  pure a = EdgeListBuilder $ \_ acc -> (a, acc)+  EdgeListBuilder kf <*> EdgeListBuilder ka = EdgeListBuilder $ \src acc ->+    let (f, acc1) = kf src acc+        (a, acc2) = ka src acc1+     in (f a, acc2)++instance Monad (EdgeListBuilder rs ci co v) where+  (>>=) (EdgeListBuilder k) f = EdgeListBuilder $ \src acc ->+    let (a, acc') = k src acc+        EdgeListBuilder k' = f a+     in k' src acc'++-- | Per-edge entry. Wires the InCtor's match-guard, gives the user+-- a 'PayloadProj' handle (so OverloadedRecordDot resolves+-- @d.field@), runs the body to accumulate the edge, and finalizes+-- into a closed 'Edge'.+onCmd ::+  forall ci ifs rs co v w.+  (Show v) =>+  InCtor ci ifs ->+  (PayloadProj rs ci ifs -> EdgeBuilder rs ci co v '[] w ()) ->+  EdgeListBuilder rs ci co v ()+onCmd ic body = EdgeListBuilder $ \src acc ->+  let initial =+        PartialEdge+          { peGuard = matchInCtor ic,+            peUpdate = UKeep,+            peOutput = [],+            peTargets = [],+            peInCtor = Just (PeInCtor ic)+          }+      (_, finalPE) = runEdgeBuilder (body (PayloadProj ic)) initial+      edgeIx = length acc+      edge = finalizeEdge edgeIx src finalPE+   in ((), edge : acc)++-- | ε-edge entry: no input projection, no input-ctor match-guard.+-- The guard starts at 'PTop' (so any conjuncts the body adds via+-- 'requireEq' / 'requireGuard' constitute the full guard). Inside+-- the body, no 'PayloadProj' is supplied, so 'OverloadedRecordDot'+-- access to the input is unavailable; use 'Keiki.Core.inpCtor'+-- directly with an explicit 'InCtor' if needed.+onEpsilon ::+  forall rs ci co v w.+  (Show v) =>+  EdgeBuilder rs ci co v '[] w () ->+  EdgeListBuilder rs ci co v ()+onEpsilon body = EdgeListBuilder $ \src acc ->+  let initial =+        PartialEdge+          { peGuard = PTop,+            peUpdate = UKeep,+            peOutput = [],+            peTargets = [],+            peInCtor = Nothing+          }+      (_, finalPE) = runEdgeBuilder body initial+      edgeIx = length acc+      edge = finalizeEdge edgeIx src finalPE+   in ((), edge : acc)++-- | Close a 'PartialEdge' into an 'Edge'. Validation: 'peTargets'+-- must have exactly one entry; missing or duplicated 'goto' calls+-- raise a runtime 'error' naming the source vertex and edge index.+-- The 'peOutput' list (zero or more 'OutTerm's accumulated by+-- 'emit' / 'emitWith' calls) flows directly into the resulting+-- 'Edge.output' field.+finalizeEdge ::+  (Show v) =>+  Int ->+  v ->+  PartialEdge rs ci co v w ->+  Edge (HsPred rs ci) rs ci co v+finalizeEdge n src pe = case peTargets pe of+  [t] ->+    Edge+      { guard = peGuard pe,+        update = peUpdate pe,+        output = peOutput pe,+        target = t+      }+  [] ->+    error $+      "Keiki.Builder: edge #"+        <> show n+        <> " from "+        <> show src+        <> ": goto missing. Each onCmd/"+        <> "onEpsilon body must end with exactly one goto V."+  (_ : _ : _) ->+    error $+      "Keiki.Builder: edge #"+        <> show n+        <> " from "+        <> show src+        <> ": goto called more than once. "+        <> "Each onCmd/onEpsilon body must end with "+        <> "exactly one goto V."++-- * Vertex builder --------------------------------------------------------++-- | Top-level builder. Accumulates @[(v, [Edge ...])]@ entries, one+-- per 'from' call. 'buildTransducer' converts the result into a+-- 'SymTransducer''s 'edgesOut' function via @lookup@ with @[]@ as+-- default for unmentioned vertices.+newtype VertexBuilder rs ci co v a = VertexBuilder+  { runVertexBuilder ::+      [(v, [Edge (HsPred rs ci) rs ci co v])] ->+      (a, [(v, [Edge (HsPred rs ci) rs ci co v])])+  }++instance Functor (VertexBuilder rs ci co v) where+  fmap f (VertexBuilder k) = VertexBuilder $ \vs ->+    let (a, vs') = k vs in (f a, vs')++instance Applicative (VertexBuilder rs ci co v) where+  pure a = VertexBuilder $ \vs -> (a, vs)+  VertexBuilder kf <*> VertexBuilder ka = VertexBuilder $ \vs ->+    let (f, vs1) = kf vs+        (a, vs2) = ka vs1+     in (f a, vs2)++instance Monad (VertexBuilder rs ci co v) where+  (>>=) (VertexBuilder k) f = VertexBuilder $ \vs ->+    let (a, vs') = k vs+        VertexBuilder k' = f a+     in k' vs'++-- | Group edges by source vertex. The argument is an+-- 'EdgeListBuilder' do-block of 'onCmd' / 'onEpsilon' calls; each+-- call adds one outgoing edge to the named vertex.+--+-- A vertex not mentioned in any 'from' block defaults to @[]@+-- (terminal). To assert "this vertex is terminal" explicitly,+-- write @from V (Prelude.pure ())@.+from ::+  (Eq v, Show v) =>+  v ->+  EdgeListBuilder rs ci co v () ->+  VertexBuilder rs ci co v ()+from v eb = VertexBuilder $ \vs ->+  let (_, accFinal) = runEdgeListBuilder eb v []+      entry = (v, Prelude.reverse accFinal)+   in ((), entry : vs)++-- | Top-level entry. Run the 'VertexBuilder' do-block to produce a+-- list of @(vertex, edges)@ pairs, then assemble a 'SymTransducer'+-- from the initial vertex, initial register file, finality+-- predicate, and a closure over the lookup table.+--+-- Duplicate-vertex entries (which can arise when two 'from' blocks+-- accidentally declare the same vertex) are merged: 'edgesOut'+-- returns the concatenation of every entry's edges in declaration+-- order.+--+-- The @Bounded v@ / @Enum v@ constraints are not currently used by+-- 'buildTransducer' itself but are recorded as reserved for a+-- future @withCompletenessCheck@ combinator that would assert every+-- vertex appears in some 'from' block.+buildTransducer ::+  forall rs ci co v.+  (Bounded v, Enum v, Eq v, Show v) =>+  v ->+  RegFile rs ->+  (v -> Bool) ->+  VertexBuilder rs ci co v () ->+  SymTransducer (HsPred rs ci) rs v ci co+buildTransducer initS initR isF vb =+  SymTransducer+    { edgesOut = \v -> Prelude.concatMap snd (Prelude.filter ((== v) . fst) vmap),+      initial = initS,+      initialRegs = initR,+      isFinal = isF+    }+  where+    (_, vmap) = runVertexBuilder vb []
+ src/Keiki/Composition.hs view
@@ -0,0 +1,1275 @@+{-# LANGUAGE TypeFamilies #-}+-- 'compose''s @Disjoint (Names rs1) (Names rs2)@ constraint is the+-- documented precondition that @rs1@ and @rs2@ have disjoint+-- slot-name domains; the body uses raw 'UCombine' (decision logged+-- in EP-18) so GHC sees the constraint as unused. Same reasoning as+-- "Keiki.Core"'s 'combine'.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Sequential composition of two 'SymTransducer's.+--+-- The single user-facing value is 'compose'. Given a transducer @t1@+-- whose output alphabet is @mid@ and a transducer @t2@ whose input+-- alphabet is also @mid@, @compose t1 t2@ is the composite transducer+-- whose input is t1's input, whose output is t2's output, whose+-- vertex is the pair (wrapped in 'Composite' so 'Bounded'/'Enum'+-- derive cleanly), and whose register file is @'Append' rs1 rs2@.+--+-- See @docs/research/composition-combinators-design.md@ for the+-- formal semantics, the substitution algorithm, the proof sketch+-- of single-valuedness preservation, and the documented+-- limitations (t1 outputs must be 'OPack', t2 mid-side guards must+-- be structural, both must avoid the v1 escape hatches).+--+-- Both EP-11 (under MP-4) and the design note are the source of+-- truth; this module's haddock summarises the mechanics, not the+-- rationale.+module Keiki.Composition+  ( -- * The composite vertex+    Composite (..),++    -- * Sequential composition+    compose,++    -- * Disjoint-input dispatch+    alternative,++    -- * Single-step feedback+    feedback1,++    -- * Index / term weakening (exposed for advanced uses)+    WeakenR (..),+    weakenL,+    weakenLTerm,+    weakenLPred,+    weakenLUpdate,+    weakenRTerm,+    weakenRPred,+    weakenRUpdate,+    weakenROutFields,++    -- * Substitution (exposed for advanced uses)+    substTerm,+    substPred,+    substUpdate,+    substOut,+    substOutFields,++    -- * Either lifters (alternative-side, exposed for advanced uses)+    leftInCtor,+    rightInCtor,+    leftWireCtor,+    rightWireCtor,+    liftLTermAlt,+    liftRTermAlt,+    liftLPredAlt,+    liftRPredAlt,+    liftLUpdateAlt,+    liftRUpdateAlt,+    liftLOutAlt,+    liftROutAlt,+    liftLOutFieldsAlt,+    liftROutFieldsAlt,++    -- * N-ary coproduct injectors (EP-48)+    wireCtor3At1,+    wireCtor3At2,+    wireCtor3At3,+    inCtor3At1,+    inCtor3At2,+    inCtor3At3,+    outTerm3At1,+    outTerm3At2,+    outTerm3At3,+  )+where++import Keiki.Core+import Keiki.Generics (Append, appendRegFile)+import NoThunks.Class (NoThunks (..), allNoThunks)+import Unsafe.Coerce (unsafeCoerce)++-- * The composite vertex ---------------------------------------------------++-- | The composite of two vertex types. A newtype around a pair so+-- 'Bounded'/'Enum'/'Eq'/'Show' derive cleanly without orphan+-- instances on @(s1, s2)@ — those would conflict with downstream+-- code.+data Composite s1 s2 = Composite !s1 !s2+  deriving (Eq, Show)++instance (Bounded s1, Bounded s2) => Bounded (Composite s1 s2) where+  minBound = Composite minBound minBound+  maxBound = Composite maxBound maxBound++-- | Column-major enumeration: @Composite s1 s2@ enumerates+-- @s2@ within each @s1@. Indexing assumes both component+-- @Enum@s have contiguous @[minBound .. maxBound]@ ranges (the+-- common case for a derived 'Enum' on an enum-like data type).+instance+  ( Bounded s1,+    Enum s1,+    Bounded s2,+    Enum s2+  ) =>+  Enum (Composite s1 s2)+  where+  toEnum n =+    let n2 = fromEnum (maxBound :: s2) - fromEnum (minBound :: s2) + 1+        (q, r) = n `divMod` n2+     in Composite+          (toEnum (q + fromEnum (minBound :: s1)))+          (toEnum (r + fromEnum (minBound :: s2)))+  fromEnum (Composite a b) =+    let n2 = fromEnum (maxBound :: s2) - fromEnum (minBound :: s2) + 1+        ai = fromEnum a - fromEnum (minBound :: s1)+        bi = fromEnum b - fromEnum (minBound :: s2)+     in ai * n2 + bi++-- The 'Composite' constructor is strict in both components by+-- construction (see the bang patterns above), so leaks can only enter+-- through the children. The instance recurses into both.+instance (NoThunks s1, NoThunks s2) => NoThunks (Composite s1 s2) where+  showTypeOf _ = "Composite"+  wNoThunks ctx (Composite a b) =+    allNoThunks+      [ noThunks ("Composite.left" : ctx) a,+        noThunks ("Composite.right" : ctx) b+      ]++-- * WeakenR: lift an Index over rs2 to (Append rs1 rs2) -------------------++-- | Lift a tail-side 'Index' (or 'IndexN') across an rs1 prefix.+-- The class is indexed by @rs1@; instances walk rs1's slot list with+-- 'SIdx' / 'IS' prepends, converting an @'Index' rs2 r@ into an+-- @'Index' (Append rs1 rs2) r@ and an @'IndexN' s rs2 r@ into an+-- @'IndexN' s (Append rs1 rs2) r@.+class WeakenR (rs1 :: [Slot]) where+  weakenR ::+    forall rs2 r. Index rs2 r -> Index (Append rs1 rs2) r+  weakenRIndexN ::+    forall rs2 s r. IndexN s rs2 r -> IndexN s (Append rs1 rs2) r++instance WeakenR '[] where+  weakenR i = i+  weakenRIndexN i = i++instance (WeakenR rs1) => WeakenR ('(s, t) ': rs1) where+  weakenR i = SIdx (weakenR @rs1 i)+  weakenRIndexN i = IS (weakenRIndexN @rs1 i)++-- * weakenL: lift an Index over rs1 to (Append rs1 rs2) -------------------++-- | Lift a head-side 'Index' across an rs2 suffix. Walks the+-- existing 'Index' shape; @ZIdx@ stays @ZIdx@, @SIdx i@ recurses.+weakenL :: forall rs1 rs2 r. Index rs1 r -> Index (Append rs1 rs2) r+weakenL ZIdx = ZIdx+weakenL (SIdx i) = SIdx (weakenL @_ @rs2 i)++-- | Walk a 'Term' and weaken every register read across an rs2+-- suffix. 'TInpCtorField' / 'TLit' do not touch the register file,+-- so they pass through unchanged.+weakenLTerm ::+  forall rs1 rs2 ci ifs r.+  Term rs1 ci ifs r -> Term (Append rs1 rs2) ci ifs r+weakenLTerm (TLit r) = TLit r+weakenLTerm (TReg ix) = TReg (weakenL @rs1 @rs2 ix)+weakenLTerm (TInpCtorField ic ix) = TInpCtorField ic ix+weakenLTerm (TApp1 f t) = TApp1 f (weakenLTerm @rs1 @rs2 t)+weakenLTerm (TArith op a b) =+  TArith op (weakenLTerm @rs1 @rs2 a) (weakenLTerm @rs1 @rs2 b)+weakenLTerm (TApp2 f a b) =+  TApp2+    f+    (weakenLTerm @rs1 @rs2 a)+    (weakenLTerm @rs1 @rs2 b)++-- | Walk an 'HsPred' and weaken every term inside it.+weakenLPred ::+  forall rs1 rs2 ci.+  HsPred rs1 ci -> HsPred (Append rs1 rs2) ci+weakenLPred PTop = PTop+weakenLPred PBot = PBot+weakenLPred (PAnd p q) =+  PAnd+    (weakenLPred @rs1 @rs2 p)+    (weakenLPred @rs1 @rs2 q)+weakenLPred (POr p q) =+  POr+    (weakenLPred @rs1 @rs2 p)+    (weakenLPred @rs1 @rs2 q)+weakenLPred (PNot p) = PNot (weakenLPred @rs1 @rs2 p)+weakenLPred (PEq a b) =+  PEq+    (weakenLTerm @rs1 @rs2 a)+    (weakenLTerm @rs1 @rs2 b)+weakenLPred (PInCtor ic) = PInCtor ic+weakenLPred (PCmp op a b) =+  PCmp+    op+    (weakenLTerm @rs1 @rs2 a)+    (weakenLTerm @rs1 @rs2 b)++-- | Walk an 'Update' and weaken every register write + every+-- right-hand-side 'Term'. The slot-name index @w@ is preserved by+-- weakening — adding new slots to the right of @rs1@ does not change+-- which slot names the update writes.+weakenLUpdate ::+  forall rs1 rs2 w ci.+  Update rs1 w ci -> Update (Append rs1 rs2) w ci+weakenLUpdate UKeep = UKeep+weakenLUpdate (USet ix t) =+  USet+    (weakenLIndexN @rs1 @rs2 ix)+    (weakenLTerm @rs1 @rs2 t)+weakenLUpdate (UCombine a b) =+  UCombine+    (weakenLUpdate @rs1 @rs2 a)+    (weakenLUpdate @rs1 @rs2 b)++-- | Slot-name-tagged analogue of 'weakenL'. Walks an existing+-- 'IndexN' shape; @IZ@ stays @IZ@, @IS i@ recurses. Preserves the+-- slot symbol carried by the index.+weakenLIndexN :: forall rs1 rs2 s r. IndexN s rs1 r -> IndexN s (Append rs1 rs2) r+weakenLIndexN IZ = IZ+weakenLIndexN (IS i) = IS (weakenLIndexN @_ @rs2 i)++-- * weakenR-walking helpers: lift terms / preds / updates over an rs1 prefix --++-- | Walk a 'Term' on a tail-side register file and lift every register+-- read across an rs1 prefix using 'weakenR'. The input alphabet @ci@+-- is preserved.+weakenRTerm ::+  forall rs1 rs2 ci ifs r.+  (WeakenR rs1) =>+  Term rs2 ci ifs r -> Term (Append rs1 rs2) ci ifs r+weakenRTerm (TLit r) = TLit r+weakenRTerm (TReg ix) = TReg (weakenR @rs1 ix)+weakenRTerm (TInpCtorField ic ix) = TInpCtorField ic ix+weakenRTerm (TApp1 f t) = TApp1 f (weakenRTerm @rs1 @rs2 t)+weakenRTerm (TArith op a b) =+  TArith op (weakenRTerm @rs1 @rs2 a) (weakenRTerm @rs1 @rs2 b)+weakenRTerm (TApp2 f a b) =+  TApp2+    f+    (weakenRTerm @rs1 @rs2 a)+    (weakenRTerm @rs1 @rs2 b)++-- | Walk an 'HsPred' on a tail-side register file and lift every term+-- inside via 'weakenRTerm'.+weakenRPred ::+  forall rs1 rs2 ci.+  (WeakenR rs1) =>+  HsPred rs2 ci -> HsPred (Append rs1 rs2) ci+weakenRPred PTop = PTop+weakenRPred PBot = PBot+weakenRPred (PAnd p q) =+  PAnd+    (weakenRPred @rs1 @rs2 p)+    (weakenRPred @rs1 @rs2 q)+weakenRPred (POr p q) =+  POr+    (weakenRPred @rs1 @rs2 p)+    (weakenRPred @rs1 @rs2 q)+weakenRPred (PNot p) = PNot (weakenRPred @rs1 @rs2 p)+weakenRPred (PEq a b) =+  PEq+    (weakenRTerm @rs1 @rs2 a)+    (weakenRTerm @rs1 @rs2 b)+weakenRPred (PInCtor ic) = PInCtor ic+weakenRPred (PCmp op a b) =+  PCmp+    op+    (weakenRTerm @rs1 @rs2 a)+    (weakenRTerm @rs1 @rs2 b)++-- | Walk an 'Update' on a tail-side register file and lift every+-- register write + RHS 'Term' across an rs1 prefix. The slot-name+-- index @w@ is preserved.+weakenRUpdate ::+  forall rs1 rs2 w ci.+  (WeakenR rs1) =>+  Update rs2 w ci -> Update (Append rs1 rs2) w ci+weakenRUpdate UKeep = UKeep+weakenRUpdate (USet ix t) =+  USet+    (weakenRIndexN @rs1 ix)+    (weakenRTerm @rs1 @rs2 t)+weakenRUpdate (UCombine a b) =+  UCombine+    (weakenRUpdate @rs1 @rs2 a)+    (weakenRUpdate @rs1 @rs2 b)++-- | Walk an 'OutFields' chain on a tail-side register file and lift+-- every term across an rs1 prefix.+weakenROutFields ::+  forall rs1 rs2 ci ifs fs.+  (WeakenR rs1) =>+  OutFields rs2 ci ifs fs -> OutFields (Append rs1 rs2) ci ifs fs+weakenROutFields OFNil = OFNil+weakenROutFields (OFCons t rest) =+  OFCons+    (weakenRTerm @rs1 @rs2 t)+    (weakenROutFields @rs1 @rs2 rest)++-- | Walk an 'OutTerm' on a tail-side register file and lift every+-- register read across an rs1 prefix. The 'OPack' wrapping is+-- structurally preserved; only the underlying 'OutFields' chain is+-- walked.+weakenROut ::+  forall rs1 rs2 ci co.+  (WeakenR rs1) =>+  OutTerm rs2 ci co -> OutTerm (Append rs1 rs2) ci co+weakenROut (OPack ic wc fs) =+  OPack ic wc (weakenROutFields @rs1 @rs2 fs)++-- * weakenL-walking helpers (output-term variant) -------------------------++-- | Walk an 'OutFields' chain on a head-side register file and lift+-- every term across an rs2 suffix.+weakenLOutFields ::+  forall rs1 rs2 ci ifs fs.+  OutFields rs1 ci ifs fs -> OutFields (Append rs1 rs2) ci ifs fs+weakenLOutFields OFNil = OFNil+weakenLOutFields (OFCons t rest) =+  OFCons+    (weakenLTerm @rs1 @rs2 t)+    (weakenLOutFields @rs1 @rs2 rest)++-- | Walk an 'OutTerm' on a head-side register file and lift every+-- register read across an rs2 suffix.+weakenLOut ::+  forall rs1 rs2 ci co.+  OutTerm rs1 ci co -> OutTerm (Append rs1 rs2) ci co+weakenLOut (OPack ic wc fs) =+  OPack ic wc (weakenLOutFields @rs1 @rs2 fs)++-- * Substitution algorithm -------------------------------------------------++-- | The integer position of an 'Index' in its slot list.+-- (Local replica of 'Keiki.Core''s internal @indexInt@; not+-- exported there.)+indexInt :: Index rs r -> Int+indexInt ZIdx = 0+indexInt (SIdx i) = 1 + indexInt i++-- | Existential wrapper around a 'Term' so 'nthTerm' can return one+-- without exposing the field's type at the call site.+data SomeTerm rs ci where+  SomeTerm :: Term rs ci ifs r -> SomeTerm rs ci++-- | Walk an 'OutFields' chain to position @n@. Returns @Nothing@+-- when @n@ overshoots the chain (a bug in the caller; the design's+-- structural-alignment assumption guarantees @n@ is in range when+-- the constructor names match).+nthTerm :: Int -> OutFields rs ci ifs fs -> Maybe (SomeTerm rs ci)+nthTerm _ OFNil = Nothing+nthTerm 0 (OFCons t _) = Just (SomeTerm t)+nthTerm n (OFCons _ rest)+  | n > 0 = nthTerm (n - 1) rest+  | otherwise = Nothing++-- | Substitute a t2-side 'Term' against t1's edge output. See the+-- design note's "Substituting a Term" section for the rules.+--+-- The result reads from the appended register file+-- @Append rs1 rs2@: rs1 reads come from t1's of1 traversal (these+-- propagate t1's input @ci1@); rs2 reads come from t2's term+-- weakened across the rs1 prefix.+substTerm ::+  forall rs1 rs2 ci1 mid ifs2 ifsR r.+  (WeakenR rs1) =>+  Term rs2 mid ifs2 r ->+  OutTerm rs1 ci1 mid ->+  Term (Append rs1 rs2) ci1 ifsR r+substTerm (TLit r) _o1 = TLit r+substTerm (TReg ix2) _o1 = TReg (weakenR @rs1 ix2)+substTerm (TInpCtorField ic2 ix2) o1 =+  case o1 of+    OPack _ic1 wc1 of1+      | icName ic2 == wcName wc1 ->+          let n = indexInt ix2+           in case nthTerm n of1 of+                Just (SomeTerm tm) ->+                  -- tm :: Term rs1 ci1 ifsTm r' (r' ~ r and ifsTm ~ ifsR+                  -- structurally; the slot list of ic2 mirrors of1's tuple+                  -- shape via the GRecord/GTuple Generic derivations, and+                  -- of1's elements all read t1's input at the OPack's+                  -- schema). 'unsafeCoerceTerm' realigns both the result+                  -- type and the input field schema.+                  weakenLTerm @rs1 @rs2 (unsafeCoerceTerm tm)+                Nothing ->+                  error+                    ( "Keiki.Composition.compose: nthTerm overflow at\+                      \ position "+                        <> show n+                        <> " for InCtor "+                        <> icName ic2+                        <> " — t2 reads a field t1's OutFields doesn't expose.\+                           \ This indicates a structural mismatch between\+                           \ t1's wireCtor and t2's InCtor for the shared\+                           \ mid type."+                    )+      | otherwise ->+          error+            ( "Keiki.Composition.compose: TInpCtorField over "+                <> icName ic2+                <> " but t1's edge produced "+                <> wcName wc1+                <> " — caller should ensure structural alignment of mid's\+                   \ constructors. Substitution at this position is\+                   \ unsound; the composite edge guard's PInCtor\+                   \ substitution should make the edge unsatisfiable\+                   \ before evaluation reaches this term."+            )+substTerm (TApp1 f t) o1 = TApp1 f (substTerm @rs1 @rs2 t o1)+substTerm (TArith op a b) o1 =+  TArith op (substTerm @rs1 @rs2 a o1) (substTerm @rs1 @rs2 b o1)+substTerm (TApp2 f a b) o1 =+  TApp2+    f+    (substTerm @rs1 @rs2 a o1)+    (substTerm @rs1 @rs2 b o1)++-- | Existentially-coerce a 'Term''s result type /and/ input field+-- schema. Unsound in general; justified here by the structural-+-- alignment invariant the design note documents: when+-- @icName ic2 == wcName wc1@, the slot list of @ic2@ and the field+-- tuple of @wc1@ are derived from the same 'Generic' representation, so+-- positional reads agree on type; and the substituted term reads t1's+-- input at t1's 'OPack' schema, which is the schema the composite+-- 'OPack' is rebuilt at (see 'substOut').+unsafeCoerceTerm ::+  forall rs ci ifs ifs' r r'. Term rs ci ifs' r' -> Term rs ci ifs r+unsafeCoerceTerm = unsafeCoerce++-- | Substitute a t2-side 'HsPred' against t1's edge output. See+-- the design note's "Substituting an HsPred" section for the rules.+substPred ::+  forall rs1 rs2 ci1 mid.+  (WeakenR rs1) =>+  HsPred rs2 mid ->+  OutTerm rs1 ci1 mid ->+  HsPred (Append rs1 rs2) ci1+substPred PTop _o1 = PTop+substPred PBot _o1 = PBot+substPred (PAnd p q) o1 =+  PAnd+    (substPred @rs1 @rs2 p o1)+    (substPred @rs1 @rs2 q o1)+substPred (POr p q) o1 =+  POr+    (substPred @rs1 @rs2 p o1)+    (substPred @rs1 @rs2 q o1)+substPred (PNot p) o1 = PNot (substPred @rs1 @rs2 p o1)+substPred (PEq a b) o1 =+  PEq+    (substTerm @rs1 @rs2 a o1)+    (substTerm @rs1 @rs2 b o1)+substPred (PCmp op a b) o1 =+  PCmp+    op+    (substTerm @rs1 @rs2 a o1)+    (substTerm @rs1 @rs2 b o1)+substPred (PInCtor ic2) o1 =+  case o1 of+    OPack _ wc1 _+      | icName ic2 == wcName wc1 -> PTop+      | otherwise -> PBot++-- | Substitute a t2-side 'Update' against t1's edge output. The+-- slot-name index @w@ is preserved by substitution — substituting+-- input reads inside the right-hand-side 'Term's does not change+-- which slot names the update writes.+substUpdate ::+  forall rs1 rs2 w ci1 mid.+  (WeakenR rs1) =>+  Update rs2 w mid ->+  OutTerm rs1 ci1 mid ->+  Update (Append rs1 rs2) w ci1+substUpdate UKeep _o1 = UKeep+substUpdate (USet ix2 t) o1 =+  USet+    (weakenRIndexN @rs1 ix2)+    (substTerm @rs1 @rs2 t o1)+substUpdate (UCombine a b) o1 =+  UCombine+    (substUpdate @rs1 @rs2 a o1)+    (substUpdate @rs1 @rs2 b o1)++-- | Substitute a t2-side 'OutFields' chain against t1's edge output.+substOutFields ::+  forall rs1 rs2 ci1 mid ifs2 ifsR fs.+  (WeakenR rs1) =>+  OutFields rs2 mid ifs2 fs ->+  OutTerm rs1 ci1 mid ->+  OutFields (Append rs1 rs2) ci1 ifsR fs+substOutFields OFNil _o1 = OFNil+substOutFields (OFCons t rest) o1 =+  OFCons+    (substTerm @rs1 @rs2 t o1)+    (substOutFields @rs1 @rs2 rest o1)++-- | Substitute a t2-side 'OutTerm' against t1's edge output. The+-- composite's 'OPack' is tagged with t1's input constructor (the+-- @ic1@ from o1) — not t2's @ic2_co@. See the design note's+-- "Substituting an OutTerm" section.+substOut ::+  forall rs1 rs2 ci1 mid co.+  (WeakenR rs1) =>+  OutTerm rs2 mid co ->+  OutTerm rs1 ci1 mid ->+  OutTerm (Append rs1 rs2) ci1 co+substOut (OPack _ic2_co wc2_co of2) o1 =+  case o1 of+    OPack ic1 _wc1 _of1 ->+      OPack+        (unsafeCoerceInCtor ic1)+        wc2_co+        (substOutFields @rs1 @rs2 of2 o1)++-- | Coerce an 'InCtor''s @ci@ type. Unsound in general; the+-- composite uses ic1 (originally over @ci1@) and the type already+-- aligns — the call site is a structural identity. We use coerce+-- here only because the @InCtor@ shape doesn't admit a phantom+-- @ci@ tag we could thread through; this is a one-line escape+-- to keep the substitution writable. The runtime behaviour is+-- correct: ic1's icMatch / icBuild are exactly what 'solveOutput'+-- on the composite needs.+unsafeCoerceInCtor :: InCtor ci ifs -> InCtor ci' ifs+unsafeCoerceInCtor = unsafeCoerce++-- * Either lifters (alternative-side) -------------------------------------++-- | Lift an 'InCtor' from the left arm of an 'Either' input alphabet.+-- The resulting 'InCtor' matches only on @Left _@ inputs and+-- preserves the underlying constructor's slot list and round-trip;+-- 'icBuild' wraps the rebuilt @ci1@ in 'Left' so the lifted+-- transducer's 'solveOutput' walks back to the original input form.+leftInCtor :: InCtor ci1 ifs -> InCtor (Either ci1 ci2) ifs+leftInCtor InCtor {icName = n, icMatch = m, icBuild = b} =+  InCtor+    { icName = n,+      icMatch = \case+        Left c1 -> m c1+        Right _ -> Nothing,+      icBuild = Left . b+    }++-- | Lift an 'InCtor' from the right arm of an 'Either' input+-- alphabet. Symmetric to 'leftInCtor'.+rightInCtor :: InCtor ci2 ifs -> InCtor (Either ci1 ci2) ifs+rightInCtor InCtor {icName = n, icMatch = m, icBuild = b} =+  InCtor+    { icName = n,+      icMatch = \case+        Left _ -> Nothing+        Right c2 -> m c2,+      icBuild = Right . b+    }++-- | Lift a 'WireCtor' from the left arm of an 'Either' output+-- alphabet. Matches only on @Left _@ outputs; rebuilds via+-- @Left . wcBuild@.+leftWireCtor :: WireCtor co1 fs -> WireCtor (Either co1 co2) fs+leftWireCtor WireCtor {wcName = n, wcMatch = m, wcBuild = b} =+  WireCtor+    { wcName = n,+      wcMatch = \case+        Left c1 -> m c1+        Right _ -> Nothing,+      wcBuild = Left . b+    }++-- | Lift a 'WireCtor' from the right arm of an 'Either' output+-- alphabet. Symmetric to 'leftWireCtor'.+rightWireCtor :: WireCtor co2 fs -> WireCtor (Either co1 co2) fs+rightWireCtor WireCtor {wcName = n, wcMatch = m, wcBuild = b} =+  WireCtor+    { wcName = n,+      wcMatch = \case+        Left _ -> Nothing+        Right c2 -> m c2,+      wcBuild = Right . b+    }++-- | Lift a 'Term' from the left side's input alphabet to+-- @Either ci1 ci2@. Walks the AST and adjusts every 'TInpCtorField'+-- to read through 'leftInCtor'. 'TLit' / 'TReg' don't depend on+-- @ci@ and pass through unchanged.+liftLTermAlt ::+  forall rs ci1 ci2 ifs r.+  Term rs ci1 ifs r -> Term rs (Either ci1 ci2) ifs r+liftLTermAlt (TLit r) = TLit r+liftLTermAlt (TReg ix) = TReg ix+liftLTermAlt (TInpCtorField ic ix) = TInpCtorField (leftInCtor ic) ix+liftLTermAlt (TApp1 f t) = TApp1 f (liftLTermAlt @rs @ci1 @ci2 t)+liftLTermAlt (TArith op a b) =+  TArith op (liftLTermAlt @rs @ci1 @ci2 a) (liftLTermAlt @rs @ci1 @ci2 b)+liftLTermAlt (TApp2 f a b) =+  TApp2 f (liftLTermAlt @rs @ci1 @ci2 a) (liftLTermAlt @rs @ci1 @ci2 b)++-- | Lift a 'Term' from the right side's input alphabet to+-- @Either ci1 ci2@. Symmetric to 'liftLTermAlt'.+liftRTermAlt ::+  forall rs ci1 ci2 ifs r.+  Term rs ci2 ifs r -> Term rs (Either ci1 ci2) ifs r+liftRTermAlt (TLit r) = TLit r+liftRTermAlt (TReg ix) = TReg ix+liftRTermAlt (TInpCtorField ic ix) = TInpCtorField (rightInCtor ic) ix+liftRTermAlt (TApp1 f t) = TApp1 f (liftRTermAlt @rs @ci1 @ci2 t)+liftRTermAlt (TArith op a b) =+  TArith op (liftRTermAlt @rs @ci1 @ci2 a) (liftRTermAlt @rs @ci1 @ci2 b)+liftRTermAlt (TApp2 f a b) =+  TApp2 f (liftRTermAlt @rs @ci1 @ci2 a) (liftRTermAlt @rs @ci1 @ci2 b)++-- | Lift an 'HsPred' from the left side's input alphabet to+-- @Either ci1 ci2@. Walks the AST and recurses through every+-- 'Term' via 'liftLTermAlt'.+liftLPredAlt ::+  forall rs ci1 ci2.+  HsPred rs ci1 -> HsPred rs (Either ci1 ci2)+liftLPredAlt PTop = PTop+liftLPredAlt PBot = PBot+liftLPredAlt (PAnd p q) =+  PAnd+    (liftLPredAlt @rs @ci1 @ci2 p)+    (liftLPredAlt @rs @ci1 @ci2 q)+liftLPredAlt (POr p q) =+  POr+    (liftLPredAlt @rs @ci1 @ci2 p)+    (liftLPredAlt @rs @ci1 @ci2 q)+liftLPredAlt (PNot p) = PNot (liftLPredAlt @rs @ci1 @ci2 p)+liftLPredAlt (PEq a b) =+  PEq+    (liftLTermAlt @rs @ci1 @ci2 a)+    (liftLTermAlt @rs @ci1 @ci2 b)+liftLPredAlt (PInCtor ic) = PInCtor (leftInCtor ic)+liftLPredAlt (PCmp op a b) =+  PCmp+    op+    (liftLTermAlt @rs @ci1 @ci2 a)+    (liftLTermAlt @rs @ci1 @ci2 b)++-- | Lift an 'HsPred' from the right side's input alphabet to+-- @Either ci1 ci2@. Symmetric to 'liftLPredAlt'.+liftRPredAlt ::+  forall rs ci1 ci2.+  HsPred rs ci2 -> HsPred rs (Either ci1 ci2)+liftRPredAlt PTop = PTop+liftRPredAlt PBot = PBot+liftRPredAlt (PAnd p q) =+  PAnd+    (liftRPredAlt @rs @ci1 @ci2 p)+    (liftRPredAlt @rs @ci1 @ci2 q)+liftRPredAlt (POr p q) =+  POr+    (liftRPredAlt @rs @ci1 @ci2 p)+    (liftRPredAlt @rs @ci1 @ci2 q)+liftRPredAlt (PNot p) = PNot (liftRPredAlt @rs @ci1 @ci2 p)+liftRPredAlt (PEq a b) =+  PEq+    (liftRTermAlt @rs @ci1 @ci2 a)+    (liftRTermAlt @rs @ci1 @ci2 b)+liftRPredAlt (PInCtor ic) = PInCtor (rightInCtor ic)+liftRPredAlt (PCmp op a b) =+  PCmp+    op+    (liftRTermAlt @rs @ci1 @ci2 a)+    (liftRTermAlt @rs @ci1 @ci2 b)++-- | Lift an 'Update' from the left side's input alphabet to+-- @Either ci1 ci2@. The slot-name index @w@ is preserved; only the+-- right-hand-side 'Term's are walked.+liftLUpdateAlt ::+  forall rs w ci1 ci2.+  Update rs w ci1 -> Update rs w (Either ci1 ci2)+liftLUpdateAlt UKeep = UKeep+liftLUpdateAlt (USet ix t) = USet ix (liftLTermAlt @rs @ci1 @ci2 t)+liftLUpdateAlt (UCombine a b) = UCombine (liftLUpdateAlt a) (liftLUpdateAlt b)++-- | Lift an 'Update' from the right side's input alphabet to+-- @Either ci1 ci2@. Symmetric to 'liftLUpdateAlt'.+liftRUpdateAlt ::+  forall rs w ci1 ci2.+  Update rs w ci2 -> Update rs w (Either ci1 ci2)+liftRUpdateAlt UKeep = UKeep+liftRUpdateAlt (USet ix t) = USet ix (liftRTermAlt @rs @ci1 @ci2 t)+liftRUpdateAlt (UCombine a b) = UCombine (liftRUpdateAlt a) (liftRUpdateAlt b)++-- | Lift an 'OutFields' chain from the left side's input alphabet to+-- @Either ci1 ci2@. Recurses on each 'Term' via 'liftLTermAlt'.+liftLOutFieldsAlt ::+  forall rs ci1 ci2 ifs fs.+  OutFields rs ci1 ifs fs -> OutFields rs (Either ci1 ci2) ifs fs+liftLOutFieldsAlt OFNil = OFNil+liftLOutFieldsAlt (OFCons t rest) =+  OFCons+    (liftLTermAlt @rs @ci1 @ci2 t)+    (liftLOutFieldsAlt @rs @ci1 @ci2 rest)++-- | Lift an 'OutFields' chain from the right side's input alphabet+-- to @Either ci1 ci2@. Symmetric to 'liftLOutFieldsAlt'.+liftROutFieldsAlt ::+  forall rs ci1 ci2 ifs fs.+  OutFields rs ci2 ifs fs -> OutFields rs (Either ci1 ci2) ifs fs+liftROutFieldsAlt OFNil = OFNil+liftROutFieldsAlt (OFCons t rest) =+  OFCons+    (liftRTermAlt @rs @ci1 @ci2 t)+    (liftROutFieldsAlt @rs @ci1 @ci2 rest)++-- | Lift an 'OutTerm' from the left side's alphabets to+-- @Either ci1 ci2@ on the input and @Either co1 co2@ on the output.+-- The 'OPack' is re-tagged: the 'InCtor' becomes 'leftInCtor', the+-- 'WireCtor' becomes 'leftWireCtor', and every 'Term' inside the+-- 'OutFields' is lifted via 'liftLTermAlt'.+liftLOutAlt ::+  forall rs ci1 ci2 co1 co2.+  OutTerm rs ci1 co1 ->+  OutTerm rs (Either ci1 ci2) (Either co1 co2)+liftLOutAlt (OPack ic wc fs) =+  OPack+    (leftInCtor ic)+    (leftWireCtor wc)+    (liftLOutFieldsAlt @rs @ci1 @ci2 fs)++-- | Lift an 'OutTerm' from the right side's alphabets to+-- @Either ci1 ci2@ on the input and @Either co1 co2@ on the output.+-- Symmetric to 'liftLOutAlt'.+liftROutAlt ::+  forall rs ci1 ci2 co1 co2.+  OutTerm rs ci2 co2 ->+  OutTerm rs (Either ci1 ci2) (Either co1 co2)+liftROutAlt (OPack ic wc fs) =+  OPack+    (rightInCtor ic)+    (rightWireCtor wc)+    (liftROutFieldsAlt @rs @ci1 @ci2 fs)++-- * N-ary coproduct injectors (EP-48) ------------------------------------++-- $naryInjectors+--+-- These inject one already-derived event family into a sum of /three/+-- families, represented as the right-nested @'Either' co1 ('Either' co2+-- co3)@ on the output side (and the analogous nest on the input side).+-- They are nothing more than the shipped binary lifts+-- ('leftWireCtor'\/'rightWireCtor', 'leftInCtor'\/'rightInCtor',+-- 'liftLOutAlt'\/'liftROutAlt') composed the right number of times, so+-- no new machinery — and no new @unsafeCoerce@ — is introduced.+--+-- == Beyond three families+--+-- The pattern generalizes to any arity by composing one more @right…@+-- per extra family. For a right-nested sum of @N@ families, family @k@+-- injects via @right…@ applied @k-1@ times then @left…@ once, and the+-- /last/ family @N@ via @right…@ applied @N-1@ times (no trailing+-- @left…@, since the innermost arm is the bare family type). The+-- arity-3 helpers below are the worked common case; for larger @N@,+-- compose 'leftWireCtor'\/'rightWireCtor' (etc.) directly.+--+-- == Name-uniqueness obligation+--+-- 'Keiki.Core.solveOutput' matches input constructors by @icName@+-- /string equality/ (and groups outputs by @wcName@). When several+-- families are summed into one alphabet, their constructor-name strings+-- must be pairwise distinct, or inversion can silently recover the wrong+-- command. The 'Either' wrapper keeps families structurally apart at the+-- match step, but the names are the human-facing contract — keep them+-- unique across summed families.++-- | Inject a family-1 'WireCtor' into a 3-family output sum+-- @'Either' co1 ('Either' co2 co3)@.+wireCtor3At1 :: WireCtor co1 fs -> WireCtor (Either co1 (Either co2 co3)) fs+wireCtor3At1 = leftWireCtor++-- | Inject a family-2 'WireCtor' into a 3-family output sum.+wireCtor3At2 :: WireCtor co2 fs -> WireCtor (Either co1 (Either co2 co3)) fs+wireCtor3At2 = rightWireCtor . leftWireCtor++-- | Inject a family-3 (last) 'WireCtor' into a 3-family output sum.+wireCtor3At3 :: WireCtor co3 fs -> WireCtor (Either co1 (Either co2 co3)) fs+wireCtor3At3 = rightWireCtor . rightWireCtor++-- | Inject a family-1 'InCtor' into a 3-family input sum+-- @'Either' ci1 ('Either' ci2 ci3)@.+inCtor3At1 :: InCtor ci1 ifs -> InCtor (Either ci1 (Either ci2 ci3)) ifs+inCtor3At1 = leftInCtor++-- | Inject a family-2 'InCtor' into a 3-family input sum.+inCtor3At2 :: InCtor ci2 ifs -> InCtor (Either ci1 (Either ci2 ci3)) ifs+inCtor3At2 = rightInCtor . leftInCtor++-- | Inject a family-3 (last) 'InCtor' into a 3-family input sum.+inCtor3At3 :: InCtor ci3 ifs -> InCtor (Either ci1 (Either ci2 ci3)) ifs+inCtor3At3 = rightInCtor . rightInCtor++-- | Re-home a whole family-1 edge output term into the 3-family+-- input/output sums. This is the function that lets an edge authored+-- against family 1 participate in a transducer over the summed alphabet;+-- 'Keiki.Core.solveOutput' inverts the summed event straight back to the+-- (injected) command.+outTerm3At1 ::+  OutTerm rs ci1 co1 ->+  OutTerm rs (Either ci1 (Either ci2 ci3)) (Either co1 (Either co2 co3))+outTerm3At1 = liftLOutAlt++-- | Re-home a whole family-2 edge output term into the 3-family sums.+outTerm3At2 ::+  OutTerm rs ci2 co2 ->+  OutTerm rs (Either ci1 (Either ci2 ci3)) (Either co1 (Either co2 co3))+outTerm3At2 = liftROutAlt . liftLOutAlt++-- | Re-home a whole family-3 (last) edge output term into the 3-family sums.+outTerm3At3 ::+  OutTerm rs ci3 co3 ->+  OutTerm rs (Either ci1 (Either ci2 ci3)) (Either co1 (Either co2 co3))+outTerm3At3 = liftROutAlt . liftROutAlt++-- * Multi-event composition (EP-19 M6) -----------------------------------++-- | An in-progress t2-edge path through a multi-event 'compose'+-- expansion. Carries the accumulated guard (the lifted @e1@-guard+-- conjoined with each consumed t2-edge's substituted guard), the+-- chained update, the concatenation of t2-edge outputs (each+-- substituted against the corresponding mid-symbol), and the t2-+-- state after consuming all mid-symbols processed so far.+--+-- The existential @w@ closes over the chained 'Update''s slot-set+-- index — each step extends the chain via 'UCombine', so the+-- effective @w@ grows but is hidden from the surrounding code.+data PartialPath rs1 rs2 ci1 co s2+  = forall w.+    PartialPath+      !(HsPred (Append rs1 rs2) ci1) -- accumulated guard+      !(Update (Append rs1 rs2) w ci1) -- chained update (existential w)+      ![OutTerm (Append rs1 rs2) ci1 co] -- accumulated outputs in order+      !s2 -- t2-state after consuming so far++-- * compose ----------------------------------------------------------------++-- | Sequential composition of two 'SymTransducer's. The composite+-- consumes t1's input alphabet and produces t2's output alphabet,+-- threading t1's events through t2 transparently.+--+-- Semantics (see the design note for the full case analysis):+--+--   * For each ε-edge of t1 from @s1@: one composite edge that+--     advances @s1@ and leaves @s2@ unchanged.+--   * For each non-ε edge of t1 from @s1@, paired with each edge of+--     t2 from @s2@: one composite edge whose guard / update /+--     output are t2's structurally substituted against t1's edge+--     output, conjoined with t1's lifted guard / update.+--+-- The composite preserves the keiki guarantees:+--   * Mechanical inversion: 'solveOutput' on the composite+--     'OPack' walks t2's wire form back through t1's structural+--     reads, recovering @ci1@.+--   * Hidden-input check: 'checkHiddenInputs' surfaces+--     transitively-hidden fields (a field of @ci1@ that t1 keeps+--     in @mid@ but t2 drops on the wire is flagged at the+--     composite level).+--   * Symbolic single-valuedness: the composite is single-valued+--     when t1 and t2 are individually single-valued; the+--     substitution is a syntactic rewrite that preserves+--     unsatisfiability.+--+-- See the design note for the proofs / case analyses.+compose ::+  forall rs1 rs2 s1 s2 ci1 mid co.+  ( WeakenR rs1,+    Disjoint (Names rs1) (Names rs2)+  ) =>+  SymTransducer (HsPred rs1 ci1) rs1 s1 ci1 mid ->+  SymTransducer (HsPred rs2 mid) rs2 s2 mid co ->+  SymTransducer+    (HsPred (Append rs1 rs2) ci1)+    (Append rs1 rs2)+    (Composite s1 s2)+    ci1+    co+compose t1 t2 =+  SymTransducer+    { edgesOut = composedEdges,+      initial = Composite (initial t1) (initial t2),+      initialRegs = appendRegFile (initialRegs t1) (initialRegs t2),+      isFinal = \(Composite a b) -> isFinal t1 a && isFinal t2 b+    }+  where+    composedEdges ::+      Composite s1 s2 ->+      [ Edge+          (HsPred (Append rs1 rs2) ci1)+          (Append rs1 rs2)+          ci1+          co+          (Composite s1 s2)+      ]+    composedEdges (Composite s1 s2) =+      concatMap (composeEdge s1 s2) (edgesOut t1 s1)++    composeEdge ::+      s1 ->+      s2 ->+      Edge (HsPred rs1 ci1) rs1 ci1 mid s1 ->+      [ Edge+          (HsPred (Append rs1 rs2) ci1)+          (Append rs1 rs2)+          ci1+          co+          (Composite s1 s2)+      ]+    composeEdge _s1Source s2 e1 = case output e1 of+      [] -> [epsilonEdge e1 s2]+      [o1] -> map (productEdge e1 o1) (edgesOut t2 s2)+      mids ->+        -- EP-19 M6 library-side chain expansion: walk t2 through the+        -- N mid-symbols of e1's output list, gathering all paths+        -- (cartesian product of t2 edges per intermediate state).+        -- Each completed path becomes one length-N composite edge.+        -- See docs/research/gsm-widening-design.md §5.+        map (finalizePath e1) (expandPaths mids (initialPath e1 s2))++    epsilonEdge ::+      Edge (HsPred rs1 ci1) rs1 ci1 mid s1 ->+      s2 ->+      Edge+        (HsPred (Append rs1 rs2) ci1)+        (Append rs1 rs2)+        ci1+        co+        (Composite s1 s2)+    epsilonEdge e1 s2 = case e1 of+      Edge {update = u1} ->+        Edge+          { guard = weakenLPred @rs1 @rs2 (guard e1),+            update = weakenLUpdate @rs1 @rs2 u1,+            output = [],+            target = Composite (target e1) s2+          }++    productEdge ::+      Edge (HsPred rs1 ci1) rs1 ci1 mid s1 ->+      OutTerm rs1 ci1 mid ->+      Edge (HsPred rs2 mid) rs2 mid co s2 ->+      Edge+        (HsPred (Append rs1 rs2) ci1)+        (Append rs1 rs2)+        ci1+        co+        (Composite s1 s2)+    productEdge e1 o1 e2 = case (e1, e2) of+      -- Pattern-match brings each Edge's existential @w1@ / @w2@ into+      -- scope so that 'weakenLUpdate' / 'substUpdate' can pin their+      -- result types to the inputs' indices. The composite @w@+      -- becomes 'Concat w1 w2'; we use the raw 'UCombine' constructor+      -- (no 'Disjoint' constraint) because the structural+      -- disjointness here — left writes only into the rs1 prefix,+      -- right writes only into the rs2 suffix — cannot be promoted+      -- to a type-level constraint without carrying a @Subset w+      -- (Names rs)@ witness through 'Edge'\'s existential and a+      -- hand-written lemma function. External aggregate authors+      -- still get the static 'Disjoint' check via 'combine'; this+      -- internal call site is the documented exception. See EP-18's+      -- Decision Log entry dated 2026-05-02.+      (Edge {update = u1}, Edge {update = u2}) ->+        Edge+          { guard =+              PAnd+                (weakenLPred @rs1 @rs2 (guard e1))+                (substPred @rs1 @rs2 (guard e2) o1),+            update =+              UCombine+                (weakenLUpdate @rs1 @rs2 u1)+                (substUpdate @rs1 @rs2 u2 o1),+            output = map (\o2 -> substOut @rs1 @rs2 o2 o1) (output e2),+            target = Composite (target e1) (target e2)+          }++    -- \| The starting point for EP-19 M6's chain expansion. Carries+    -- t1's edge contribution (lifted guard, lifted update) into the+    -- accumulator; the recursion threads through it without re-+    -- referencing t1.+    initialPath ::+      Edge (HsPred rs1 ci1) rs1 ci1 mid s1 ->+      s2 ->+      PartialPath rs1 rs2 ci1 co s2+    initialPath e1 s2 = case e1 of+      Edge {update = u1} ->+        PartialPath+          (weakenLPred @rs1 @rs2 (guard e1))+          (weakenLUpdate @rs1 @rs2 u1)+          []+          s2++    -- \| Enumerate all t2-edge paths that consume the supplied+    -- mid-symbol list in order, starting from the path's current+    -- t2-state. Each completed path's @ppEnd@ is the t2-state after+    -- the final mid-symbol; its @ppOutputs@ is the concatenation of+    -- t2-edge outputs (each substituted against the corresponding+    -- mid-symbol of t1's edge), in declaration order.+    --+    -- The base case (empty mid-symbol list) returns the path as-is —+    -- the recursion has consumed every mid-symbol.+    expandPaths ::+      [OutTerm rs1 ci1 mid] ->+      PartialPath rs1 rs2 ci1 co s2 ->+      [PartialPath rs1 rs2 ci1 co s2]+    expandPaths [] path = [path]+    expandPaths (o : rest) path =+      case path of+        PartialPath g u outs s2 ->+          concatMap+            (\e2 -> expandPaths rest (stepPath g u outs o s2 e2))+            (edgesOut t2 s2)++    -- \| Extend a path by one t2-edge consuming one mid-symbol.+    -- Pattern-matching @e2@ brings the edge's existential @w2@ into+    -- scope so the @UCombine@ can chain into the accumulator. The+    -- accumulator's existential @w@ comes from 'PartialPath'.+    stepPath ::+      forall w.+      HsPred (Append rs1 rs2) ci1 ->+      Update (Append rs1 rs2) w ci1 ->+      [OutTerm (Append rs1 rs2) ci1 co] ->+      OutTerm rs1 ci1 mid ->+      s2 ->+      Edge (HsPred rs2 mid) rs2 mid co s2 ->+      PartialPath rs1 rs2 ci1 co s2+    stepPath g u outs o _s2 e2 = case e2 of+      Edge {update = u2} ->+        PartialPath+          (PAnd g (substPred @rs1 @rs2 (guard e2) o))+          (UCombine u (substUpdate @rs1 @rs2 u2 o))+          (outs ++ map (\o2 -> substOut @rs1 @rs2 o2 o) (output e2))+          (target e2)++    -- \| Convert a fully-expanded path to a composite edge by+    -- borrowing t1's @target@ for the composite's target.+    finalizePath ::+      Edge (HsPred rs1 ci1) rs1 ci1 mid s1 ->+      PartialPath rs1 rs2 ci1 co s2 ->+      Edge+        (HsPred (Append rs1 rs2) ci1)+        (Append rs1 rs2)+        ci1+        co+        (Composite s1 s2)+    finalizePath e1 (PartialPath g u outs s2End) =+      Edge+        { guard = g,+          update = u,+          output = outs,+          target = Composite (target e1) s2End+        }++-- * alternative -----------------------------------------------------------++-- | Disjoint-input dispatch of two 'SymTransducer's. The composite+-- consumes @Either ci1 ci2@ and emits @Either co1 co2@: a @Left ci1@+-- advances @t1@ from its current sub-vertex (leaving t2's+-- sub-vertex unchanged) and emits @Left co1@; a @Right ci2@+-- advances @t2@ from its current sub-vertex (leaving t1's+-- sub-vertex unchanged) and emits @Right co2@. The two+-- sub-aggregates have **independent state** that evolves in+-- parallel as commands arrive for the appropriate arm.+--+-- Semantics:+--+--   * The composite vertex is 'Composite' s1 s2 (the same product+--     vertex 'compose' uses). At each composite vertex+--     @Composite s1 s2@, the outgoing edges are the union of:+--       - t1's edges from @s1@, lifted into the @Either ci1 ci2@+--         input alphabet (gated to fire only on @Left _@) with+--         target @Composite (target e1) s2@;+--       - t2's edges from @s2@, lifted symmetrically with target+--         @Composite s1 (target e2)@.+--   * Initial state is @Composite (initial t1) (initial t2)@.+--   * @isFinal@ requires both sub-aggregates to be final.+--+-- The composite preserves the keiki guarantees:+--+--   * Mechanical inversion: each composite output @OPack (leftInCtor+--     ic) (leftWireCtor wc) of_lifted@ runs the underlying+--     @icMatch@ / @icBuild@ unchanged after stripping the @Left@+--     wrapping; symmetric for @Right@.+--   * Hidden-input check: each side's per-edge check inherits via+--     the lifters (which preserve 'TInpCtorField' slot reads).+--   * Symbolic single-valuedness: at any @Composite s1 s2@, the t1+--     edges' guards (which require @Left _@ via 'leftInCtor') and+--     t2 edges' guards (which require @Right _@ via 'rightInCtor')+--     are pairwise mutually exclusive. Within each arm,+--     single-valuedness reduces to the underlying sub-aggregate's+--     check at the relevant sub-vertex. **No cross-transducer+--     mutual-exclusion check is needed** — the @Either@ arms make+--     it vacuous.+--+-- See 'docs/research/composition-combinators-design.md' under+-- "Combinators beyond `compose`" → "`alternative` — admitted" for+-- the full design record (signature, semantics, single-step+-- example, preservation arguments, limitations).+alternative ::+  forall rs1 rs2 s1 s2 ci1 ci2 co1 co2.+  ( WeakenR rs1,+    Disjoint (Names rs1) (Names rs2)+  ) =>+  SymTransducer (HsPred rs1 ci1) rs1 s1 ci1 co1 ->+  SymTransducer (HsPred rs2 ci2) rs2 s2 ci2 co2 ->+  SymTransducer+    (HsPred (Append rs1 rs2) (Either ci1 ci2))+    (Append rs1 rs2)+    (Composite s1 s2)+    (Either ci1 ci2)+    (Either co1 co2)+alternative t1 t2 =+  SymTransducer+    { edgesOut = altEdges,+      initial = Composite (initial t1) (initial t2),+      initialRegs = appendRegFile (initialRegs t1) (initialRegs t2),+      isFinal = \(Composite s1 s2) -> isFinal t1 s1 && isFinal t2 s2+    }+  where+    altEdges ::+      Composite s1 s2 ->+      [ Edge+          (HsPred (Append rs1 rs2) (Either ci1 ci2))+          (Append rs1 rs2)+          (Either ci1 ci2)+          (Either co1 co2)+          (Composite s1 s2)+      ]+    altEdges (Composite s1 s2) =+      map (liftEdgeL s2) (edgesOut t1 s1)+        ++ map (liftEdgeR s1) (edgesOut t2 s2)++    liftEdgeL ::+      s2 ->+      Edge (HsPred rs1 ci1) rs1 ci1 co1 s1 ->+      Edge+        (HsPred (Append rs1 rs2) (Either ci1 ci2))+        (Append rs1 rs2)+        (Either ci1 ci2)+        (Either co1 co2)+        (Composite s1 s2)+    liftEdgeL s2 e1 = case e1 of+      Edge {update = u1} ->+        Edge+          { guard =+              liftLPredAlt @(Append rs1 rs2) @ci1 @ci2+                (weakenLPred @rs1 @rs2 (guard e1)),+            update =+              liftLUpdateAlt @(Append rs1 rs2) @_ @ci1 @ci2+                (weakenLUpdate @rs1 @rs2 u1),+            output =+              map+                ( liftLOutAlt @(Append rs1 rs2) @ci1 @ci2 @co1 @co2+                    . weakenLOut @rs1 @rs2+                )+                (output e1),+            target = Composite (target e1) s2+          }++    liftEdgeR ::+      s1 ->+      Edge (HsPred rs2 ci2) rs2 ci2 co2 s2 ->+      Edge+        (HsPred (Append rs1 rs2) (Either ci1 ci2))+        (Append rs1 rs2)+        (Either ci1 ci2)+        (Either co1 co2)+        (Composite s1 s2)+    liftEdgeR s1 e2 = case e2 of+      Edge {update = u2} ->+        Edge+          { guard =+              liftRPredAlt @(Append rs1 rs2) @ci1 @ci2+                (weakenRPred @rs1 @rs2 (guard e2)),+            update =+              liftRUpdateAlt @(Append rs1 rs2) @_ @ci1 @ci2+                (weakenRUpdate @rs1 @rs2 u2),+            output =+              map+                ( liftROutAlt @(Append rs1 rs2) @ci1 @ci2 @co1 @co2+                    . weakenROut @rs1 @rs2+                )+                (output e2),+            target = Composite s1 (target e2)+          }++-- * feedback1 ------------------------------------------------------------++-- | Single-step feedback combinator. Models one round of an+-- aggregate ↔ stateless-policy reaction: the aggregate consumes an+-- external command, the policy observes the aggregate's emitted+-- event and emits a follow-up command, and the aggregate consumes+-- that follow-up. The composite emits the aggregate's *second*+-- event as its output.+--+-- Operationally, @feedback1 t f = compose t (compose f t)@:+--+--   * The inner @compose f t@ chains the policy's output (a+--     command for t) into a second invocation of t.+--   * The outer @compose t _@ feeds t's first event into that+--     inner pipeline.+--+-- The composite vertex is @Composite s1 (Composite s2 s1)@ —+-- "outer t state, then (policy state, inner t state)". Even though+-- the inner @s1@ is the same Haskell type as the outer, it occupies+-- a distinct dimension of the composite vertex tuple, so+-- 'Keiki.Symbolic.isSingleValuedSym''s per-vertex enumeration walks+-- all @|s1| * |s2| * |s1|@ combinations independently.+--+-- Multi-round patterns are expressed by nesting:+--+--     twoRounds = feedback1 (feedback1 t f) f+--+-- The pure-core boundary holds because there is no loop — the+-- cascade runs exactly once per external command.+--+-- == Constraints and limitations+--+-- The constraint @'Disjoint' ('Names' rs1) ('Names' ('Append' rs2 rs1))@+-- is the outer 'compose''s slot-disjointness check applied to+-- @rs1@ versus @Append rs2 rs1@. Since @rs1@ appears on both sides,+-- the constraint is only satisfiable when @rs1 = '[]@ — i.e. when+-- t is **stateless** (its register file is empty). For non-empty+-- @rs1@, the call site fails with a slot-collision @TypeError@.+--+-- This restriction follows from the design's+-- "two-stacked-@compose@" reduction: t appears twice, and keiki's+-- register-file model gives each appearance its own copy of @rs1@.+-- A "shared-state" variant — where the second t reads/writes the+-- first t's registers via a custom edge construction — is+-- documented as a future extension and is not in scope for MP-8.+-- The "stateless policy" recommendation (single vertex, empty+-- @rs2@) is convention rather than enforced; if violated, the+-- composite still typechecks but the single-step semantics may+-- not be preserved.+--+-- == Future extensions+--+-- A bounded-step variant @feedbackN n t f@ that iterates the+-- cascade @n@ times is documented in+-- 'docs/research/composition-combinators-design.md' but is not+-- shipped here.+--+-- See 'docs/research/composition-combinators-design.md' under+-- "Combinators beyond `compose`" → "`feedback1` — admitted+-- (single-step reduction)" for the full design record.+feedback1 ::+  forall rs1 rs2 s1 s2 ci co.+  ( WeakenR rs1,+    WeakenR rs2,+    Disjoint (Names rs2) (Names rs1),+    Disjoint (Names rs1) (Names (Append rs2 rs1))+  ) =>+  SymTransducer (HsPred rs1 ci) rs1 s1 ci co ->+  SymTransducer (HsPred rs2 co) rs2 s2 co ci ->+  SymTransducer+    (HsPred (Append rs1 (Append rs2 rs1)) ci)+    (Append rs1 (Append rs2 rs1))+    (Composite s1 (Composite s2 s1))+    ci+    co+feedback1 t f = compose t (compose f t)
+ src/Keiki/Core.hs view
@@ -0,0 +1,1903 @@+-- 'combine''s 'Disjoint' constraint is the static check itself; GHC+-- sees it as unused (the body is @UCombine@) and would otherwise warn.+-- Same reasoning for any future helpers that re-export the constraint+-- as a typed witness.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | The pure core of keiki: the symbolic-register transducer.+--+-- This module is the v1 prototype of the design pinned by+-- @docs/research/dsl-shape-for-symbolic-register.md@ (the DSL note),+-- @docs/research/effects-boundary.md@ (the boundary note), and+-- @docs/research/synthesis-c-foundation-b-presentation-with-worked-examples.md@+-- (the working baseline). See those notes for the rationale behind every+-- shape declared here.+--+-- All v1 escape hatches were retired by MasterPlan 6 (see the+-- Outcomes section of+-- @docs/masterplans/6-retire-remaining-v1-escape-hatches-in-pure-core-ofn-pmatchc-unsafecombine-static-check.md@):+-- @TInpField@ / @OPack@'s hand-written inverse (MP-2 EP-1), 'OFn' /+-- 'mkOut' (MP-6 EP-16), 'PMatchC' / 'matchCmd' (MP-6 EP-17), and+-- 'unsafeCombine' (MP-6 EP-18, replaced by the static 'Disjoint'+-- check on 'combine').+--+-- == Guard-authoring operators (EP-45)+--+-- Predicates and term arithmetic can be written with infix operators+-- that mirror their Prelude counterparts:+--+--   * Relational (build 'HsPred', @infix 4@): '.<' '.<=' '.>' '.>='+--     '.==' './=' — each an alias for 'PCmp'/'PEq' at a fixed relation.+--   * Logical (combine 'HsPred'): '.&&' (@infixr 3@, 'PAnd'),+--     '.||' (@infixr 2@, 'POr'), 'pnot' ('PNot').+--   * Arithmetic (build 'Term', mirror @+@\/@-@\/@*@): '.+' '.-' '.*' —+--     aliases for 'tadd'\/'tsub'\/'tmul'.+--+-- The verbose carrier signatures have synonyms: 'Pred' @rs ci@ for+-- @'HsPred' rs ci@, 'Guarded' @rs s ci co@ for+-- @'SymTransducer' ('HsPred' rs ci) rs s ci co@ (and+-- 'Keiki.Symbolic.SymGuarded' for the SBV-backed carrier).+--+-- Keep spaces around the operators (@lit a .* lit b@); a dot touching an+-- identifier (@x.y@) is OverloadedRecordDot field access. If you import+-- "Data.SBV" alongside this module, import it qualified — SBV exports+-- the same operator names.+module Keiki.Core+  ( -- * Slots and the register file+    Slot,+    RegFile (..),+    Index (..),+    (!),++    -- * Index resolution from labels+    HasIndex (..),++    -- * Term language+    Term (..),+    NumOp (..),++    -- * Input-side structural constructor (v2)+    InCtor (..),+    AssembleRegFile,+    KnownSlotNames (..),++    -- * Slot-name machinery (re-exported from "Keiki.Internal.Slots")+    IndexN (..),+    HasIndexN (..),+    Disjoint,+    Concat,+    Names,++    -- * Update language+    Update (..),+    combine,++    -- * Output term language+    WireCtor (..),+    OutFields (..),+    (*:),+    oNil,+    OutTerm (..),++    -- * Predicate carrier (v1 first-class AST)+    HsPred (..),+    Pred,+    Cmp (..),++    -- * Effective Boolean algebra+    BoolAlg (..),+    Sat (..),++    -- * Edges and the transducer+    Edge (..),+    SymTransducer (..),+    Guarded,+    applyEdgeUpdate,+    edgeReadsInput,++    -- * Helpers (the user-facing DSL surface)+    matchInCtor,+    proj,+    inpCtor,+    lit,+    tadd,+    tsub,+    tmul,+    (.==),+    (.<),+    (.<=),+    (.>),+    (.>=),+    (./=),+    (.&&),+    (.||),+    pnot,+    (.+),+    (.-),+    (.*),+    pack,++    -- * Evaluators+    evalTerm,+    evalOut,+    evalPred,+    runUpdate,+    delta,+    omega,++    -- * Pure-layer entry points (effects-boundary note)+    step,+    stepEither,+    StepFailure (..),+    EdgeRef (..),+    RejectedEdgeSummary (..),+    MatchedEdgeSummary (..),+    reconstitute,+    applyEvent,+    applyEventStreaming,+    applyEvents,++    -- * Streaming-replay state wrapper (EP-19 M3)+    InFlight (..),++    -- * Build-time analyses+    solveOutput,+    HiddenInputWarning (..),+    checkHiddenInputs,++    -- * Build-time validation umbrella (EP-56)+    TransducerValidationWarning (..),+    ValidationOptions (..),+    defaultValidationOptions,+    validateTransducer,+    hiddenInputWarnings,+    opaqueGuardWarnings,+    DeterminismWarning (..),+    checkTransitionDeterminism,+    checkTransitionDeterminismPure,+    DeadEdgeOptions (..),+    defaultDeadEdgeOptions,+    DeadEdgeWarning (..),+    checkDeadEdges,++    -- * Internals exposed for testing+    termReadsInput,+    updateReadsInput,+    outFieldsHaveInpCtorField,+    detectMissingInCtorFields,+    MissingInCtorFields (..),+  )+where++import Data.Kind (Type)+import Data.List (nub, (\\))+import Data.Proxy (Proxy (..))+import Data.Set qualified as Set+import Data.Typeable (Typeable)+import GHC.OverloadedLabels (IsLabel (..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Keiki.Internal.Slots+  ( Concat,+    Disjoint,+    HasIndexN (..),+    IndexN (..),+    Names,+  )++-- | A register slot is a label paired with the type of its value.+type Slot = (Symbol, Type)++-- * Register file -----------------------------------------------------------++-- | A typed heterogeneous register tuple indexed by a list of 'Slot's.+--+-- The slot-value field is intentionally lazy: 'Keiki.Generics.emptyRegFile'+-- seeds each slot with a deferred @error "uninit: \<slot\>"@ thunk so+-- that reading an unwritten slot fails loudly with a targeted message+-- instead of returning a silent bottom. Strictness for *written*+-- slots is enforced on the write path ('setSlotN') instead — see+-- EP-23's Surprises entry for the long-running-service rationale.+data RegFile (rs :: [Slot]) where+  RNil :: RegFile '[]+  RCons ::+    (KnownSymbol s) =>+    Proxy s -> r -> RegFile rs -> RegFile ('(s, r) ': rs)++-- | A type-safe pointer into a 'RegFile'. 'ZIdx' picks the head;+-- 'SIdx' skips one slot.+data Index (rs :: [Slot]) (r :: Type) where+  ZIdx :: (KnownSymbol s) => Index ('(s, r) ': rs) r+  SIdx :: Index rs r -> Index ('(s', r') ': rs) r++-- | Runtime register lookup. Matching on 'Index' first lets GHC's GADT+-- pattern checker see that 'RNil' is unreachable — 'ZIdx' and 'SIdx'+-- both refine @rs@ to @'(_,_) ': _@.+(!) :: RegFile rs -> Index rs r -> r+regs ! ZIdx = case regs of RCons _ x _ -> x+regs ! SIdx i = case regs of RCons _ _ rest -> rest ! i++infixl 9 !++-- * IsLabel / HasIndex -----------------------------------------------------++-- | Resolve a label @s@ against a slot list @rs@ to an 'Index' for the+-- value at that slot. The functional dependency @s rs -> r@ ensures that+-- a label uniquely determines the slot's type.+class+  HasIndex (s :: Symbol) (rs :: [Slot]) (r :: Type)+    | s rs -> r+  where+  indexOf :: Index rs r++instance+  {-# OVERLAPPING #-}+  (KnownSymbol s) =>+  HasIndex s ('(s, r) ': rs) r+  where+  indexOf = ZIdx++instance+  {-# OVERLAPPABLE #-}+  forall s s' r r' rs.+  (HasIndex s rs r) =>+  HasIndex s ('(s', r') ': rs) r+  where+  indexOf = SIdx (indexOf @s @rs @r)++instance+  forall s rs r.+  (HasIndex s rs r) =>+  IsLabel s (Index rs r)+  where+  fromLabel = indexOf @s @rs @r++-- | Resolve a label directly to a 'Term' that reads the named register.+-- This instance lets call sites write @#name@ in any 'Term'-typed+-- context (the arguments of 'requireEq', the elements of 'OutFields',+-- etc.) without the @proj (#name :: Index Regs T)@ annotation that+-- 'IsLabel s (Index rs r)' alone would require.+--+-- The two 'IsLabel' instances ('Index' and 'Term') coexist because GHC+-- dispatches by the expected result type: a context expecting an+-- 'Index' (e.g. 'inpFoo'\'s argument) selects the 'Index' instance; a+-- context expecting a 'Term' (e.g. 'requireEq'\'s arguments) selects+-- this one.+instance+  forall s rs ci ifs r.+  (HasIndex s rs r) =>+  IsLabel s (Term rs ci ifs r)+  where+  fromLabel = TReg (indexOf @s @rs @r)++-- The @IsLabel s (IndexN s rs r)@ instance lives next to 'IndexN' in+-- "Keiki.Internal.Slots" so the orphan check is satisfied.++-- * Term language ----------------------------------------------------------++-- | A numeric operation carried by 'TArith'. @OpAdd@\/@OpSub@\/@OpMul@+-- are @+@\/@-@\/@*@ respectively. Kept as a single tag (rather than+-- three 'Term' constructors) so each total 'Term' walker switches on+-- one value; the three directions are recovered by the smart+-- constructors 'tadd'\/'tsub'\/'tmul'.+data NumOp = OpAdd | OpSub | OpMul+  deriving stock (Eq, Show)++-- | A pure expression over the register file and the input symbol,+-- yielding a value of type @r@.+--+-- The @ifs :: [Slot]@ parameter is the /input field schema/ this term+-- may project from: it is pinned by 'TInpCtorField' (whose 'Index' is+-- into @ifs@) and left free by terms that do not read an input field+-- ('TLit', 'TReg'). Threading @ifs@ through the AST is what lets an+-- 'OutFields' (and hence an 'OPack') guarantee /by construction/ that+-- every top-level input projection reads the same constructor schema as+-- the 'OPack''s 'InCtor' — so 'solveOutput' recovers a command field+-- with no @unsafeCoerce@. Terms that do not appear in an invertible+-- output position ('Update' right-hand sides, 'HsPred' operands)+-- existentially hide @ifs@, so it never leaks into the 'Edge' /+-- 'SymTransducer' surface. See @docs/research/tinpproj-design.md@.+data Term (rs :: [Slot]) (ci :: Type) (ifs :: [Slot]) (r :: Type) where+  TLit :: r -> Term rs ci ifs r+  TReg :: Index rs r -> Term rs ci ifs r+  -- | Structural input projection: read field @ix@ of the input+  --     constructor described by @ic@. The 'InCtor' value names the+  --     expected constructor and supplies the round-trip+  --     ('icMatch'/'icBuild') so that 'solveOutput' can mechanically+  --     recover @ci@ from an observed output. Pins the term's @ifs@ to the+  --     constructor's field schema. See @docs/research/tinpproj-design.md@.+  TInpCtorField :: InCtor ci ifs -> Index ifs r -> Term rs ci ifs r+  TApp1 ::+    (a -> r) ->+    Term rs ci ifs a ->+    Term rs ci ifs r+  TApp2 ::+    (a -> b -> r) ->+    Term rs ci ifs a ->+    Term rs ci ifs b ->+    Term rs ci ifs r+  -- | Structural arithmetic over a numeric operand type. Unlike the+  --     opaque 'TApp1'\/'TApp2' escape hatches, the SBV translator reads+  --     'TArith' for real (on a 'Keiki.Symbolic.discoverSymNum' hit), so a+  --     guard over a /computed/ value — a weighted sum, a derived cap — is+  --     visible to the solver. The 'Num' constraint prevents constructing+  --     arithmetic at non-numeric operand types; 'Typeable' lets the SBV+  --     translator dispatch on @r@. Build with 'tadd'\/'tsub'\/'tmul'.+  TArith ::+    (Num r, Typeable r) =>+    NumOp ->+    Term rs ci ifs r ->+    Term rs ci ifs r ->+    Term rs ci ifs r++-- | Per-constructor input projection. An 'InCtor' value names one+-- constructor of the input symbol type @ci@ and pins the round-trip+-- between that constructor's payload and a typed register file+-- @'RegFile' ifs@. The slot list @ifs@ is the field schema for the+-- constructor; together with 'Index' it lets call sites read fields+-- via 'OverloadedLabels' (for example @inpStart #email@).+--+-- 'icMatch' must return 'Just' iff @ci@ is the named constructor.+-- 'icBuild' is its left inverse: @icMatch (icBuild rf) == Just rf@ for+-- every well-formed @rf@.+--+-- The constraints 'AssembleRegFile' and 'KnownSlotNames' on the data+-- constructor mean that any code holding an 'InCtor' can both+-- mechanically rebuild a 'RegFile' from a bag of '(Index, value)' pairs+-- and recover the slot names of @ifs@ at run time. The instances are+-- automatic for any concrete slot list, so users do not write any+-- additional code.+--+-- See @docs/research/tinpproj-design.md@ for the design rationale and+-- the inversion algorithm that walks 'OutFields' gathering these+-- per-field reads.+data InCtor ci (ifs :: [Slot]) where+  InCtor ::+    (AssembleRegFile ifs, KnownSlotNames ifs) =>+    { icName :: String,+      icMatch :: ci -> Maybe (RegFile ifs),+      icBuild :: RegFile ifs -> ci+    } ->+    InCtor ci ifs++-- * Slot-list helper classes (v2 inversion machinery) ---------------------++-- | Recover the slot names of an @ifs :: [Slot]@ at run time. Used to+-- print precise hidden-input warnings.+class KnownSlotNames (rs :: [Slot]) where+  slotNames :: [String]++instance KnownSlotNames '[] where+  slotNames = []++instance+  (KnownSymbol s, KnownSlotNames rs) =>+  KnownSlotNames ('(s, r) ': rs)+  where+  slotNames = symbolVal (Proxy @s) : slotNames @rs++-- | An (Index, value) pair indexed by an InCtor's slot list. Using a+-- GADT existential lets us bag entries with different element types+-- under one slot list and unpack them safely via pattern matching on+-- the carried 'Index'.+data ByIndex (ifs :: [Slot]) where+  ByIndex :: Index ifs r -> r -> ByIndex ifs++-- | Class to assemble a 'RegFile' from a bag of '(Index, value)' pairs.+-- 'assemble' returns 'Just' iff every slot of @ifs@ is covered by+-- exactly one entry of the bag (extra entries beyond what slots+-- demand are ignored as long as the per-slot lookups succeed in+-- order).+class AssembleRegFile (ifs :: [Slot]) where+  assemble :: [ByIndex ifs] -> Maybe (RegFile ifs)++instance AssembleRegFile '[] where+  assemble _ = Just RNil++instance+  (KnownSymbol s, AssembleRegFile rs) =>+  AssembleRegFile ('(s, r) ': rs)+  where+  assemble entries = do+    v <- findHead entries+    rest <- assemble (popHead entries)+    pure (RCons (Proxy @s) v rest)+    where+      findHead :: [ByIndex ('(s, r) ': rs)] -> Maybe r+      findHead [] = Nothing+      findHead (ByIndex ZIdx v : _) = Just v+      findHead (_ : rest) = findHead rest++      popHead :: [ByIndex ('(s, r) ': rs)] -> [ByIndex rs]+      popHead [] = []+      popHead (ByIndex ZIdx _ : rest) = popHead rest+      popHead (ByIndex (SIdx i) v : rest) = ByIndex i v : popHead rest++-- * Update language --------------------------------------------------------++-- | The copyless update language. The @(w :: [Symbol])@ index+-- records the set of slot names this update writes; the smart+-- constructor 'combine' demands @'Disjoint' w1 w2@ to combine two+-- updates, so "each register is written at most once per edge+-- update" becomes a type-level invariant rather than a runtime check.+--+-- The 'UCombine' raw constructor is *not* constrained by 'Disjoint':+-- the invariant is enforced at the smart-constructor introduction+-- point ('combine'). This keeps internal pattern-matches in+-- "Keiki.Composition" (which reconstruct 'UCombine' values during+-- weakening / substitution) cheap. EP-18 M8 retired the v1+-- 'unsafeCombine' escape hatch; aggregate authors use 'combine'+-- exclusively.+data Update (rs :: [Slot]) (w :: [Symbol]) (ci :: Type) where+  UKeep :: Update rs '[] ci+  -- The right-hand-side 'Term''s input field schema @ifs@ is+  -- existentially hidden: updates are never inverted, so @ifs@ need not+  -- escape into the 'Update' kind (keeping 'Edge' / 'SymTransducer'+  -- unchanged).+  USet ::+    (KnownSymbol s) =>+    IndexN s rs r -> Term rs ci ifs r -> Update rs '[s] ci+  UCombine ::+    Update rs w1 ci ->+    Update rs w2 ci ->+    Update rs (Concat w1 w2) ci++-- | Smart constructor for 'UCombine'. The @'Disjoint' w1 w2@+-- constraint statically enforces that the two halves write to+-- disjoint slot-name sets; an aggregate that writes the same slot+-- twice (e.g. @'USet' #email t1 \`combine\` 'USet' #email t2@) is+-- rejected at compile time with a 'GHC.TypeError.TypeError' naming+-- the offending slot.+combine ::+  (Disjoint w1 w2) =>+  Update rs w1 ci ->+  Update rs w2 ci ->+  Update rs (Concat w1 w2) ci+combine = UCombine++-- * Output term language ---------------------------------------------------++-- | A wire-type tag for one constructor of the user's output sum @co@.+-- The functions let 'solveOutput' pattern-match an observed @co@ and+-- 'evalOut' rebuild a @co@ from its fields.+data WireCtor co fields = WireCtor+  { wcName :: String,+    wcMatch :: co -> Maybe fields,+    wcBuild :: fields -> co+  }++-- | An HList of 'Term's, one per field of the wire constructor. The+-- field-tuple type @fs@ is built up nested-pair style so that+-- 'solveOutput' can walk the HList structurally.+--+-- The @ifs :: [Slot]@ parameter is the shared input field schema of+-- every 'Term' in the list (see 'Term'). 'OPack' ties it to the+-- 'OPack''s 'InCtor', so a top-level 'TInpCtorField' inside an+-- 'OutFields' is statically an 'Index' into the 'OPack''s constructor+-- schema — 'gatherInpEntries' recovers it with no coercion.+data OutFields rs ci ifs fs where+  OFNil :: OutFields rs ci ifs ()+  OFCons ::+    Term rs ci ifs f ->+    OutFields rs ci ifs fs ->+    OutFields rs ci ifs (f, fs)++-- | Right-associative HList constructor synonym for 'OFCons'. Lets+-- 'OutFields' literals read top-to-bottom in the wire ctor's field+-- order:+--+-- > d.recipient *: d.subject *: d.at *: oNil+--+-- Identical AST: @t1 *: t2 *: oNil@ produces the same 'OutFields'+-- value as @OFCons t1 (OFCons t2 OFNil)@. Available at the AST+-- layer (here) so authors who skip the builder can use it; also+-- re-exported by "Keiki.Builder" for builder-form call sites.+(*:) :: Term rs ci ifs f -> OutFields rs ci ifs fs -> OutFields rs ci ifs (f, fs)+(*:) = OFCons++infixr 5 *:++-- | The empty 'OutFields' HList. Synonym for 'OFNil'.+oNil :: OutFields rs ci ifs ()+oNil = OFNil++-- | A pure expression yielding an output value @co@.+data OutTerm (rs :: [Slot]) (ci :: Type) (co :: Type) where+  -- | Structural pack: tagged by an input constructor (which the edge+  --     consumes) and an output wire constructor (which the edge produces),+  --     with one 'Term' per field of the wire constructor. 'solveOutput'+  --     walks the structural 'OutFields', gathering '(Index, value)' pairs+  --     against the named 'InCtor', and reconstructs the input by calling+  --     'icBuild' on the assembled register file. Empty-payload input+  --     constructors (the 'InCtor's slot list is @\'[]@) recover trivially+  --     as @icBuild ic RNil@.+  OPack ::+    InCtor ci ifs ->+    WireCtor co fields ->+    OutFields rs ci ifs fields ->+    OutTerm rs ci co++-- * Predicate carrier ------------------------------------------------------++-- | The predicate AST. Carries enough structure to evaluate guards and+-- to translate to SMT through the SBV-backed 'BoolAlg' instance in+-- "Keiki.Symbolic" (added in EP-2 of MasterPlan 2).+data HsPred (rs :: [Slot]) (ci :: Type) where+  PTop :: HsPred rs ci+  PBot :: HsPred rs ci+  PAnd :: HsPred rs ci -> HsPred rs ci -> HsPred rs ci+  POr :: HsPred rs ci -> HsPred rs ci -> HsPred rs ci+  PNot :: HsPred rs ci -> HsPred rs ci+  PEq ::+    (Eq r, Typeable r) =>+    Term rs ci ifs1 r -> Term rs ci ifs2 r -> HsPred rs ci+  -- | Structural input-constructor guard: @True@ iff the input symbol+  --     is the constructor named by the carried 'InCtor'. The SBV-backed+  --     'BoolAlg' instance recognises constructor mutual exclusion+  --     symbolically through this constructor. See+  --     @docs/research/sbv-boolalg-design.md@.+  PInCtor :: InCtor ci ifs -> HsPred rs ci+  -- | Ordering guard: compares two 'Term's of the same orderable type+  --     with the relation named by 'Cmp'. @PCmp CmpGe a b@ means @a >= b@,+  --     and so on. Unlike a threshold written through 'TApp1'\/'TApp2'+  --     (which is opaque to the solver), 'PCmp' is /structural/: the+  --     SBV-backed translator in "Keiki.Symbolic" emits a real symbolic+  --     comparison (@.<@, @.<=@, @.>@, @.>=@) whenever the operand type's+  --     'Keiki.Symbolic.SymRep' is symbolically orderable (see+  --     'Keiki.Symbolic.discoverSymOrd'); otherwise it falls back to a+  --     fresh opaque 'SBool', exactly as 'PEq' does for non-'Sym' operands.+  --     Equality is intentionally left to 'PEq' — 'Cmp' has no "equal"+  --     case. Added by EP-41.+  PCmp ::+    (Ord r, Typeable r) =>+    Cmp -> Term rs ci ifs1 r -> Term rs ci ifs2 r -> HsPred rs ci++-- | A four-way ordering relation carried by 'PCmp'. @Lt@\/@Le@\/@Gt@\/+-- @Ge@ are @<@\/@<=@\/@>@\/@>=@ respectively. Kept as a single tag+-- (rather than four 'HsPred' constructors) so the evaluator and the+-- SBV translator each switch on one value; the four directions are+-- recovered by the builder conveniences+-- 'Keiki.Builder.requireLt'\/'requireLe'\/'requireGt'\/'requireGe'.+data Cmp = CmpLt | CmpLe | CmpGt | CmpGe+  deriving stock (Eq, Show)++-- * Effective Boolean algebra ----------------------------------------------++-- | An effective Boolean algebra over @a@-typed witnesses, used as the+-- guard carrier of edges. Witness /extraction/ ('sat') is a separate,+-- stronger capability — see 'Sat'.+class BoolAlg phi a | phi -> a where+  top :: phi+  bot :: phi+  conj :: phi -> phi -> phi+  disj :: phi -> phi -> phi+  neg :: phi -> phi+  models :: phi -> a -> Bool+  isBot :: phi -> Bool++-- | A 'BoolAlg' whose witnesses can be /extracted/ from a satisfiable+-- predicate: @'sat' phi@ returns 'Just' a value satisfying @phi@, or+-- 'Nothing' when @phi@ is unsatisfiable.+--+-- Split out of 'BoolAlg' by EP-44 (MasterPlan 12). Witness+-- reconstruction needs carrier-specific evidence — for the SBV-backed+-- 'Keiki.Symbolic.SymPred' carrier, @ExtractRegFile rs@ (to rebuild the+-- register file from the solver model) and @KnownInCtors ci@ (to rebuild+-- the command) — that the algebra's build/decide methods do not. Keeping+-- 'sat' in its own class means the witness-free analyses+-- ('Keiki.Symbolic.isSingleValuedSym', which uses only 'isBot'/'conj')+-- carry no extraction constraints, so they keep type-checking on+-- register-file-existential carriers (e.g. 'Keiki.Profunctor.SomeSymTransducer')+-- and on composition-produced @ci@ types ('Either', tuples) that have no+-- 'KnownInCtors'. See @docs/research/sbv-boolalg-design.md@.+class (BoolAlg phi a) => Sat phi a where+  sat :: phi -> Maybe a++instance BoolAlg (HsPred rs ci) (RegFile rs, ci) where+  top = PTop+  bot = PBot+  conj p q = PAnd p q+  disj p q = POr p q+  neg p = PNot p+  models p (regs, ci) = evalPred p regs ci+  isBot PBot = True+  isBot _ = False++-- | The v1 syntactic carrier has no solver, hence no extractable+-- witness; 'sat' is always 'Nothing'. The precise witnesses come from+-- the SBV-backed @Sat (SymPred …)@ instance in "Keiki.Symbolic".+instance Sat (HsPred rs ci) (RegFile rs, ci) where+  sat _ = Nothing++-- * Edges and the transducer -----------------------------------------------++-- | A single transition. The 'output' is a list of 'OutTerm's:+-- @[]@ is the ε-edge (no observable emission), @[o]@ is the letter+-- edge (one event, identical to today's @'Just' o@), @[o1, o2, ...]@+-- is the multi-event edge — one transition emits N events in+-- declaration order. See @docs/research/gsm-widening-design.md@.+--+-- The @(w :: [Symbol])@ index on 'update' (the slot-name set the+-- update writes) is *existentially* quantified at the 'Edge' record+-- — different edges out of the same vertex write different slot+-- sets, but the homogeneous list @[Edge phi rs ci co s]@ in+-- 'edgesOut' demands a single @Edge@ type. The existential preserves+-- the static disjointness check at the *introduction* point of any+-- 'Update' value (via 'combine') without polluting the @Edge@'s+-- public type with a per-edge @w@ parameter.+data Edge phi rs ci co s where+  Edge ::+    { guard :: phi,+      update :: Update rs w ci,+      output :: [OutTerm rs ci co],+      target :: s+    } ->+    Edge phi rs ci co s++-- | The single source of truth: a finite control graph plus a register+-- file evolved by edges' 'update' terms.+data SymTransducer phi rs s ci co = SymTransducer+  { edgesOut :: s -> [Edge phi rs ci co s],+    initial :: s,+    initialRegs :: RegFile rs,+    isFinal :: s -> Bool+  }++-- | Readable alias for the v1 predicate carrier:+-- @'Pred' rs ci@ is exactly @'HsPred' rs ci@.+type Pred rs ci = HsPred rs ci++-- | A 'SymTransducer' whose guard carrier is the v1 'HsPred'. Collapses+-- the @'SymTransducer' ('HsPred' rs ci) rs s ci co@ signature — which+-- otherwise repeats @rs@ and @ci@ — into @'Guarded' rs s ci co@.+type Guarded rs s ci co = SymTransducer (HsPred rs ci) rs s ci co++-- | Apply an edge's update to the register file. The 'Edge''s+-- existentially-quantified @w@ index makes @'update' e@ unusable as+-- a function (GHC rejects with "escaped type variables"); this+-- helper hides the existential by pattern-matching internally.+applyEdgeUpdate ::+  Edge phi rs ci co s -> RegFile rs -> ci -> RegFile rs+applyEdgeUpdate Edge {update = u} regs ci = runUpdate u regs ci++-- | Does an edge's update read the input symbol via 'TInpCtorField'?+-- Existential-hiding companion to 'updateReadsInput'.+edgeReadsInput :: Edge phi rs ci co s -> Bool+edgeReadsInput Edge {update = u} = updateReadsInput u++-- * Helpers (DSL surface) --------------------------------------------------++-- | Structural input-constructor guard: @True@ iff the input symbol+-- is the constructor named by the supplied 'InCtor'. The SBV-backed+-- 'BoolAlg' instance can decide constructor-mutual-exclusion+-- symbolically through this guard. The semantics is+-- @evalPred (matchInCtor ic) regs ci == isJust (icMatch ic ci)@.+matchInCtor :: InCtor ci ifs -> HsPred rs ci+matchInCtor = PInCtor++-- | Read a register slot into a 'Term'.+proj :: Index rs r -> Term rs ci ifs r+proj = TReg++-- | Structural input projection: read field @ix@ of the input+-- constructor described by @ic@. The result 'Term''s @ifs@ is the+-- constructor's field schema, so an 'OutFields' built from these is+-- statically tied to the 'OPack''s 'InCtor'.+inpCtor :: InCtor ci ifs -> Index ifs r -> Term rs ci ifs r+inpCtor = TInpCtorField++-- | A constant 'Term'.+lit :: r -> Term rs ci ifs r+lit = TLit++-- | Structural arithmetic smart constructors. @tadd@\/@tsub@\/@tmul@+-- build a 'TArith' over @+@\/@-@\/@*@. The operand type must be numeric+-- ('Num') and 'Typeable'; the SBV translator reads them structurally+-- (see 'Keiki.Symbolic.discoverSymNum'), unlike the opaque 'TApp'+-- escape hatches.+tadd,+  tsub,+  tmul ::+    (Num r, Typeable r) =>+    Term rs ci ifs r -> Term rs ci ifs r -> Term rs ci ifs r+tadd = TArith OpAdd+tsub = TArith OpSub+tmul = TArith OpMul++-- | Equality predicate sugar.+(.==) :: (Eq r, Typeable r) => Term rs ci ifs1 r -> Term rs ci ifs2 r -> HsPred rs ci+(.==) = PEq++infix 4 .==++-- * Predicate & term operators (readable guard DSL) ----------------------++-- | Ordering-guard operators. Each is an alias for 'PCmp' at a fixed+-- 'Cmp': @a .>= b@ is @'PCmp' 'CmpGe' a b@ (i.e. @a >= b@); @a .< b@ is+-- @'PCmp' 'CmpLt' a b@; and so on. Same fixity as '(.==)' (@infix 4@):+-- relational operators do not chain, sit below the arithmetic operators+-- ('.+'/'.-'/'.*'), and above the logical ones ('.&&'/'.||').+(.<),+  (.<=),+  (.>),+  (.>=) ::+    (Ord r, Typeable r) => Term rs ci ifs1 r -> Term rs ci ifs2 r -> HsPred rs ci+(.<) = PCmp CmpLt+(.<=) = PCmp CmpLe+(.>) = PCmp CmpGt+(.>=) = PCmp CmpGe++infix 4 .<, .<=, .>, .>=++-- | Inequality guard. @a ./= b@ is @'pnot' (a '.==' b)@, i.e.+-- @'PNot' ('PEq' a b)@. Mirrors 'Prelude.(/=)' against the existing+-- '(.==)'.+(./=) :: (Eq r, Typeable r) => Term rs ci ifs1 r -> Term rs ci ifs2 r -> HsPred rs ci+a ./= b = PNot (PEq a b)++infix 4 ./=++-- | Conjunction / disjunction of predicates. Aliases for 'PAnd' / 'POr',+-- mirroring 'Prelude.(&&)' / 'Prelude.(||)' in fixity (@infixr 3@ /+-- @infixr 2@), so @p .&& q .|| r@ parses as @(p .&& q) .|| r@.+(.&&), (.||) :: HsPred rs ci -> HsPred rs ci -> HsPred rs ci+(.&&) = PAnd+(.||) = POr++infixr 3 .&&++infixr 2 .||++-- | Predicate negation. Alias for 'PNot'. ('Keiki.Core.BoolAlg' also+-- exposes 'neg', which is this same operation lifted through the class;+-- 'pnot' is the direct AST alias for hand-written guards.)+pnot :: HsPred rs ci -> HsPred rs ci+pnot = PNot++-- | Structural arithmetic operators on 'Term's. Aliases for+-- 'tadd' / 'tsub' / 'tmul', mirroring 'Prelude.(+)' / '(-)' / '(*)' in+-- fixity (@infixl 6@ / @infixl 6@ / @infixl 7@). Because they build the+-- structural 'TArith' node (not an opaque 'TApp'), arithmetic written+-- with them is visible to the SBV translator in "Keiki.Symbolic".+(.+),+  (.-),+  (.*) ::+    (Num r, Typeable r) => Term rs ci ifs r -> Term rs ci ifs r -> Term rs ci ifs r+(.+) = tadd+(.-) = tsub+(.*) = tmul++infixl 6 .+, .-++infixl 7 .*++-- | Structural-output construction. 'solveOutput' inverts the result+-- mechanically by walking 'OutFields' against the named input+-- constructor; users no longer supply an inverse function. The+-- 'InCtor' first argument names the @ci@ constructor the edge expects;+-- it makes recovery work even for edges whose input has no payload+-- (e.g. a singleton 'Continue' command).+pack ::+  InCtor ci ifs ->+  WireCtor co fields ->+  OutFields rs ci ifs fields ->+  OutTerm rs ci co+pack = OPack++-- * Evaluators -------------------------------------------------------------++-- | Evaluate a 'Term' against a register file and an input symbol.+evalTerm :: Term rs ci ifs r -> RegFile rs -> ci -> r+evalTerm (TLit r) _ _ = r+evalTerm (TReg ix) regs _ = regs ! ix+evalTerm (TInpCtorField ic ix) _ ci = case icMatch ic ci of+  Just rf -> rf ! ix+  Nothing -> error ("evalTerm: TInpCtorField guard violation: " ++ icName ic)+evalTerm (TApp1 f t) regs ci = f (evalTerm t regs ci)+evalTerm (TApp2 f a b) regs ci = f (evalTerm a regs ci) (evalTerm b regs ci)+evalTerm (TArith op a b) regs ci =+  applyNumOp op (evalTerm a regs ci) (evalTerm b regs ci)++-- | Interpret a 'NumOp' tag as the corresponding numeric operation.+-- The 'Num' evidence is supplied by matching the 'TArith' constructor.+applyNumOp :: (Num r) => NumOp -> r -> r -> r+applyNumOp OpAdd = (+)+applyNumOp OpSub = (-)+applyNumOp OpMul = (*)++-- | Evaluate an 'OutTerm' against a register file and an input symbol.+-- The 'InCtor' on 'OPack' is consulted only by the inverse direction+-- ('solveOutput'); evaluation just runs the wire build over the+-- evaluated 'OutFields'.+evalOut :: OutTerm rs ci co -> RegFile rs -> ci -> co+evalOut (OPack _ic ctor fields) regs ci =+  wcBuild ctor (evalOutFields fields regs ci)++evalOutFields :: OutFields rs ci ifs fs -> RegFile rs -> ci -> fs+evalOutFields OFNil _ _ = ()+evalOutFields (OFCons t rest) regs ci =+  (evalTerm t regs ci, evalOutFields rest regs ci)++-- | Evaluate a predicate to a 'Bool' on the current state.+evalPred :: HsPred rs ci -> RegFile rs -> ci -> Bool+evalPred PTop _ _ = True+evalPred PBot _ _ = False+evalPred (PAnd p q) r c = evalPred p r c && evalPred q r c+evalPred (POr p q) r c = evalPred p r c || evalPred q r c+evalPred (PNot p) r c = not (evalPred p r c)+evalPred (PEq a b) r c = evalTerm a r c == evalTerm b r c+evalPred (PInCtor ic) _ c = case icMatch ic c of+  Just _ -> True+  Nothing -> False+evalPred (PCmp op a b) r c = applyCmp op (evalTerm a r c) (evalTerm b r c)+  where+    applyCmp :: (Ord x) => Cmp -> x -> x -> Bool+    applyCmp CmpLt x y = x < y+    applyCmp CmpLe x y = x <= y+    applyCmp CmpGt x y = x > y+    applyCmp CmpGe x y = x >= y++-- | Apply an 'Update' to the register file. 'UCombine' applies left+-- then right; the smart 'combine''s 'Disjoint' constraint guarantees+-- the two halves write to disjoint slots, so the application order+-- does not affect the result.+runUpdate :: Update rs w ci -> RegFile rs -> ci -> RegFile rs+runUpdate UKeep regs _ = regs+runUpdate (USet ix t) regs ci = setSlotN ix (evalTerm t regs ci) regs+runUpdate (UCombine a b) regs ci = runUpdate b (runUpdate a regs ci) ci++-- | Pure register-file slot update at a slot-name-tagged 'IndexN'.+--+-- The bang-pattern on @v@ forces the new slot value to WHNF before+-- threading it into the rebuilt 'RCons'. Without this, every+-- 'runUpdate' / 'step' cycle in a long-running embedder accumulates+-- a tower of thunks at the written slot, which is exactly the failure+-- mode the @NoThunks (RegFile rs)@ instance ("Keiki.NoThunks") was+-- introduced to detect (EP-23). Untouched slots retain whatever+-- WHNF status they already had, which preserves+-- 'Keiki.Generics.emptyRegFile'\'s targeted @uninit:@ sentinels for+-- slots that have never been written.+setSlotN :: IndexN s rs r -> r -> RegFile rs -> RegFile rs+setSlotN IZ !v regs = case regs of RCons p _ rest -> RCons p v rest+setSlotN (IS i) !v regs = case regs of+  RCons p x rest ->+    let !rest' = setSlotN i v rest+     in RCons p x rest'++-- | Single-step transition. Returns 'Just (s', regs')' iff exactly one+-- outgoing edge has a satisfied guard.+delta ::+  (BoolAlg phi (RegFile rs, ci)) =>+  SymTransducer phi rs s ci co ->+  s ->+  RegFile rs ->+  ci ->+  Maybe (s, RegFile rs)+delta t s regs ci =+  case [ (target e, applyEdgeUpdate e regs ci)+       | e <- edgesOut t s,+         models (guard e) (regs, ci)+       ] of+    [single] -> Just single+    _ -> Nothing++-- | Single-step output. Returns the list of events emitted by the+-- unique active edge: @[]@ for an ε-edge, @[o]@ for a letter edge,+-- @[o1, o2, ...]@ for a multi-event edge. Returns @[]@ if no edge+-- (or more than one edge) is active — the caller cannot distinguish+-- "no active edge" from "active ε-edge" from this function alone;+-- use 'step' or 'delta' if that distinction matters.+omega ::+  (BoolAlg phi (RegFile rs, ci)) =>+  SymTransducer phi rs s ci co ->+  s ->+  RegFile rs ->+  ci ->+  [co]+omega t s regs ci =+  case [ [evalOut o regs ci | o <- output e]+       | e <- edgesOut t s,+         models (guard e) (regs, ci)+       ] of+    [evaluatedOuts] -> evaluatedOuts+    _ -> []++-- * Pure-layer entry points ------------------------------------------------++-- | One full step of the transducer combining 'delta' and 'omega'.+-- Returns 'Nothing' if no edge from the current vertex has a satisfied+-- guard. The inner @[co]@ is @[]@ for an ε-edge, @[o]@ for a letter+-- edge, @[o1, o2, ...]@ for a multi-event edge.+step ::+  (BoolAlg phi (RegFile rs, ci)) =>+  SymTransducer phi rs s ci co ->+  (s, RegFile rs) ->+  ci ->+  Maybe (s, RegFile rs, [co])+step t (s, regs) ci = case delta t s regs ci of+  Nothing -> Nothing+  Just (s', regs') -> Just (s', regs', omega t s regs ci)++-- | A locator for one outgoing edge: the vertex it leaves from and its+-- zero-based position in @'edgesOut' t source@. This is the canonical+-- edge-identity vocabulary shared with build-time diagnostics (EP-56).+data EdgeRef s = EdgeRef+  { edgeSource :: s,+    edgeIndex :: Int+  }+  deriving stock (Eq, Show)++-- | Why one outgoing edge was rejected during a step: its locator, its+-- declared target, and whether its guard matched (always 'False' here;+-- the field keeps the shape uniform with 'MatchedEdgeSummary' and leaves+-- room for richer rejection reasons later). Deliberately carries NO+-- register values — diagnostics summarize, they do not dump state.+data RejectedEdgeSummary s = RejectedEdgeSummary+  { rejectedEdge :: EdgeRef s,+    rejectedTarget :: s,+    rejectedGuard :: Bool+  }+  deriving stock (Eq, Show)++-- | One outgoing edge whose guard matched during a step: its locator and+-- its declared target. Carries NO register values.+data MatchedEdgeSummary s = MatchedEdgeSummary+  { matchedEdge :: EdgeRef s,+    matchedTarget :: s+  }+  deriving stock (Eq, Show)++-- | A precise explanation of why a step could not advance.+--+--   * 'NoOutgoingEdges' — the source vertex has no outgoing edges at all.+--   * 'NoMatchingEdge'   — there are outgoing edges, but none matched the+--     command; carries one 'RejectedEdgeSummary' per edge, in declaration+--     order.+--   * 'AmbiguousEdges'   — two or more guards matched the same command, a+--     runtime witness of a single-valuedness violation (the property+--     EP-56's 'checkTransitionDeterminism' proves statically); carries one+--     'MatchedEdgeSummary' per matched edge.+data StepFailure s+  = NoOutgoingEdges s+  | NoMatchingEdge s [RejectedEdgeSummary s]+  | AmbiguousEdges s [MatchedEdgeSummary s]+  deriving stock (Eq, Show)++-- | Like 'step', but returns a precise 'StepFailure' explanation on the+-- 'Left' instead of collapsing every failure into 'Nothing'. On the+-- 'Right' it returns EXACTLY the triple 'step' returns. 'step' is left+-- unchanged; this is purely additive.+stepEither ::+  (BoolAlg phi (RegFile rs, ci)) =>+  SymTransducer phi rs s ci co ->+  (s, RegFile rs) ->+  ci ->+  Either (StepFailure s) (s, RegFile rs, [co])+stepEither t (s, regs) ci =+  case zip [0 ..] (edgesOut t s) of+    [] -> Left (NoOutgoingEdges s)+    indexed ->+      let matched =+            [ (i, e)+            | (i, e) <- indexed,+              models (guard e) (regs, ci)+            ]+       in case matched of+            [] ->+              Left $+                NoMatchingEdge+                  s+                  [ RejectedEdgeSummary+                      { rejectedEdge = EdgeRef {edgeSource = s, edgeIndex = i},+                        rejectedTarget = target e,+                        rejectedGuard = False+                      }+                  | (i, e) <- indexed+                  ]+            [(_, e)] ->+              let !regs' = applyEdgeUpdate e regs ci+                  outs = [evalOut o regs ci | o <- output e]+               in Right (target e, regs', outs)+            _ ->+              Left $+                AmbiguousEdges+                  s+                  [ MatchedEdgeSummary+                      { matchedEdge = EdgeRef {edgeSource = s, edgeIndex = i},+                        matchedTarget = target e+                      }+                  | (i, e) <- matched+                  ]++-- | Apply one observed output to the state by walking outgoing edges,+-- inverting each edge's @output@ via 'solveOutput', verifying the+-- guard on the recovered input, and applying the edge's @update@.+-- Used by 'reconstitute' for full-log replay and exposed so that+-- single-event façades (notably 'Keiki.Decider.toDecider') can+-- implement an @evolve :: s -> e -> s@ step on top of it.+--+-- == Letter-only semantics+--+-- This function handles ε-edges (@output = []@; skipped because they+-- emit nothing observable) and letter edges (@output = [o]@;+-- inverted via 'solveOutput'). For multi-event edges (@output =+-- [o1, ..., oN]@ with N >= 2), this letter-flavoured 'applyEvent'+-- only inverts against the *head* of the output list, returning the+-- target vertex on a successful match. It is suitable when the+-- caller knows it is replaying letter-only events; for true+-- streaming replay across multi-event edges (where intermediate+-- events in the chain must be matched against the expected tail of+-- a prior edge's output list) use 'applyEventStreaming'.+applyEvent ::+  (BoolAlg phi (RegFile rs, ci), Eq co) =>+  SymTransducer phi rs s ci co ->+  s ->+  RegFile rs ->+  co ->+  Maybe (s, RegFile rs)+applyEvent t s regs co =+  case [ (target e, applyEdgeUpdate e regs ci)+       | e <- edgesOut t s,+         o : _ <- [output e],+         Just ci <- [solveOutput o regs co],+         models (guard e) (regs, ci)+       ] of+    [single] -> Just single+    _ -> Nothing++-- | Streaming-replay state wrapper. Used by 'applyEventStreaming'+-- (the InFlight-aware replay) and exposed as the carrier of the+-- 'Keiki.Decider.evolveStreaming' field added in EP-19 M5.+--+-- @'Settled' s@ is the state at a stable vertex — the next event+-- must be the first emission of /some/ outgoing edge of @s@.+--+-- @'InFlight' s [e2, ..., eN]@ is the mid-chain state at vertex+-- @s@ (the *target* of the in-flight chain's edge; register updates+-- have already been applied at the transition into 'InFlight'). The+-- queue holds the *evaluated* expected events in order; the next+-- observed event must equal the head, popping it; when the queue+-- empties, the wrapper transitions to @'Settled' s@.+--+-- See @docs/research/gsm-widening-design.md@ §4 for the formal+-- treatment and a worked example on the @StartRegistration@ chain.+data InFlight s co+  = Settled !s+  | InFlight !s ![co]+  deriving (Eq, Show)++-- | Apply one observed output to a streaming-replay state. Two arms:+--+--   1. @'Settled' s@ — walk outgoing edges of @s@; find the unique+--      edge whose @output@'s *head* inverts to a valid @ci@ via+--      'solveOutput' satisfying the guard. Commit to that edge, run+--      its update, evaluate the *tail* of the output list against+--      the recovered @(regs, ci)@ snapshot. If the tail is empty+--      (letter edge), return @('Settled' (target e), regs')@. If the+--      tail is non-empty (multi-event edge), return @('InFlight'+--      (target e) tail, regs')@.+--+--   2. @'InFlight' s (q1 : rest) regs@ — equality-check @q1@+--      against the observed event. On match, advance the queue+--      (returning @'Settled' s@ when @rest == []@, otherwise+--      @'InFlight' s rest@). No register update — registers were+--      updated at the @Settled → InFlight@ transition. On mismatch+--      (out-of-order replay) return 'Nothing'.+--+-- The 'Eq' constraint on @co@ supports the queue equality check.+-- Most aggregate event types derive 'Eq' (a documented expectation+-- of the foundations).+applyEventStreaming ::+  (BoolAlg phi (RegFile rs, ci), Eq co) =>+  SymTransducer phi rs s ci co ->+  InFlight s co ->+  RegFile rs ->+  co ->+  Maybe (InFlight s co, RegFile rs)+applyEventStreaming t (Settled s) regs co =+  case [ (e, ci)+       | e <- edgesOut t s,+         o : _ <- [output e],+         Just ci <- [solveOutput o regs co],+         models (guard e) (regs, ci)+       ] of+    [(e, ci)] ->+      let regs' = applyEdgeUpdate e regs ci+          evaluatedTail = [evalOut o regs ci | o <- drop 1 (output e)]+          wrapped = case evaluatedTail of+            [] -> Settled (target e)+            xs -> InFlight (target e) xs+       in Just (wrapped, regs')+    _ -> Nothing+applyEventStreaming _ (InFlight s queue) regs co = case queue of+  [] -> Nothing+  [q1]+    | q1 == co -> Just (Settled s, regs)+    | otherwise -> Nothing+  (q1 : rest)+    | q1 == co -> Just (InFlight s rest, regs)+    | otherwise -> Nothing++-- | Reconstitute @(state, registers)@ from a log of outputs by+-- replaying each event through the InFlight-aware+-- 'applyEventStreaming', which threads mid-chain state through+-- multi-event edges invisibly and unwraps to 'Settled' at the log's+-- end.+--+-- For letter-only transducers (every edge has @output@ of length 0+-- or 1) the streaming wrapper is always 'Settled' and the result is+-- identical to the pre-EP-19 letter-fold. A log that ends mid-chain+-- through a multi-event edge returns 'Nothing' — there is no valid+-- @(s, regs)@ to surface from an 'InFlight' final state.+reconstitute ::+  (BoolAlg phi (RegFile rs, ci), Eq co) =>+  SymTransducer phi rs s ci co ->+  [co] ->+  Maybe (s, RegFile rs)+reconstitute t = applyEvents t (initial t, initialRegs t)++-- | Replay a chunk of events from a caller-supplied+-- @(state, registers)@ start. Structurally similar to 'reconstitute'+-- except that the start state is an argument rather than the+-- transducer's initial state, so a runtime adapter can chunk-replay+-- the events corresponding to one logical command from any current+-- state.+--+-- Useful when the runtime preserves command boundaries (event store+-- with command-id tags, transactional batches, deterministic test+-- fixtures): replay one command's events as one atomic step and+-- consume the unwrapped final state.+--+-- == Multi-event edges (EP-19 M3)+--+-- Internally, the implementation lifts the start state to 'Settled'+-- and folds 'applyEventStreaming' over the chunk; the wrapper+-- transitions through 'InFlight' for multi-event edges and unwraps+-- back to 'Settled' when the chunk completes. A chunk that ends+-- mid-flight (the queue is non-empty at the end of the input list)+-- returns 'Nothing'; this signals a truncated chunk relative to the+-- edge's static output length.+--+-- For length-0/1 edges the behaviour is identical to the legacy+-- letter-fold; for length-2+ edges the chunk must contain the full+-- expected sequence of evaluated events in order.+--+-- Returns 'Nothing' if any event in the chunk fails to replay (e.g.+-- a malformed log, an event that does not match any active edge's+-- output at the current vertex, or a chunk that ends mid-flight).+applyEvents ::+  (BoolAlg phi (RegFile rs, ci), Eq co) =>+  SymTransducer phi rs s ci co ->+  (s, RegFile rs) ->+  [co] ->+  Maybe (s, RegFile rs)+applyEvents t (s0, regs0) cos_ = go (Settled s0) regs0 cos_+  where+    go (Settled s) regs [] = Just (s, regs)+    go (InFlight _ _) _ [] = Nothing -- chunk ended mid-flight+    go inFlight regs (co : rest) = do+      (inFlight', regs') <- applyEventStreaming t inFlight regs co+      go inFlight' regs' rest++-- * Build-time analyses ----------------------------------------------------++-- | Recover the input that produced a given output by walking+-- 'OutFields' structurally against the input constructor named by the+-- 'OPack'. Gather '(Index, value)' pairs from every top-level+-- 'TInpCtorField' read whose 'InCtor' matches by 'icName'; assemble a+-- 'RegFile' covering every slot of the 'InCtor'; call 'icBuild'.+--+-- == Recompute-and-verify (EP-47)+--+-- The command is recovered from the /invertible/ fields alone+-- (@TLit@\/@TReg@\/@TInpCtorField@); /derived/ fields (@TArith@\/@TApp1@\/+-- @TApp2@) are skipped during recovery by 'gatherInpEntries'. After the+-- command is rebuilt, the observed field tuple is rebuilt with each+-- /derived/ field recomputed forward (via 'recomputeDerivedFields') and+-- the resulting event is required to equal the observed event, so each+-- derived field is /verified/ rather than trusted — a tampered derived+-- value is rejected. Invertible fields are kept at their observed values+-- and are /not/ re-verified (so a @TReg@ audit field still round-trips+-- even when replay starts from a state whose registers are not yet+-- populated). This generalizes, at field granularity, the+-- forward-recompute-and-@Eq@-match that 'applyEventStreaming' already does+-- for multi-event tails (see @docs/research/recompute-and-verify-derived-outputs.md@).+--+-- For an all-invertible edge no field is recomputed, so the rebuilt event+-- equals the observed event by construction (the check is a no-op) and the+-- result is identical to the pre-EP-47 behavior. The build-time net+-- 'checkHiddenInputs' still rejects a schema whose command slot is read+-- only inside a derived field (a hidden input), so the command remains+-- recoverable from invertible fields alone — "the event determines the+-- command" is preserved.+solveOutput :: (Eq co) => OutTerm rs ci co -> RegFile rs -> co -> Maybe ci+solveOutput (OPack ic@InCtor {} ctor fields) regs co = do+  fs_obs <- wcMatch ctor co+  entries <- gatherInpEntries fields fs_obs ic+  rf <- assemble entries+  let ci = icBuild ic rf+      -- Rebuild the observed field tuple, recomputing ONLY the derived+      -- fields (TApp/TArith) forward; invertible fields keep their observed+      -- value. Comparing the rebuilt event to the observed one then verifies+      -- exactly the derived fields — never the invertible ones, so a+      -- register-read audit field is not re-checked against state and the+      -- command thunk is not forced for an all-invertible edge.+      rebuilt = wcBuild ctor (recomputeDerivedFields fields fs_obs regs ci)+  if rebuilt == co+    then Just ci+    else Nothing++-- | Rebuild an observed output-field tuple, recomputing each /derived/+-- field ('TApp1'\/'TApp2'\/'TArith') forward via 'evalTerm' against the+-- recovered command and the pre-update registers, while leaving every+-- /invertible/ field ('TLit'\/'TReg'\/'TInpCtorField') at its observed+-- value. Used by 'solveOutput' (EP-47 recompute-and-verify): comparing the+-- rebuilt event to the observed one (via 'Eq' on @co@) then verifies+-- exactly the derived fields. Invertible fields are deliberately /not/+-- recomputed, so (a) a register-read audit field is not re-verified against+-- the current register file — preserving the "@TReg@ round-trips" contract+-- even when replay starts from a state whose registers are not yet+-- populated — and (b) the recovered-command thunk is not forced for an+-- all-invertible edge.+recomputeDerivedFields ::+  forall rs ci ifs fs. OutFields rs ci ifs fs -> fs -> RegFile rs -> ci -> fs+recomputeDerivedFields OFNil () _ _ = ()+recomputeDerivedFields (OFCons t rest) (v, vs) regs ci =+  (recomputeOne t v, recomputeDerivedFields rest vs regs ci)+  where+    recomputeOne :: forall f. Term rs ci ifs f -> f -> f+    recomputeOne term@(TApp1 _ _) _observed = evalTerm term regs ci+    recomputeOne term@(TApp2 _ _ _) _observed = evalTerm term regs ci+    recomputeOne term@(TArith _ _ _) _observed = evalTerm term regs ci+    recomputeOne _ observed = observed++-- | Walk an 'OutFields' HList in lockstep with an observed-fields+-- tuple, gathering '(Index, value)' pairs for the named 'InCtor' from+-- the /invertible/ fields. 'TLit'\/'TReg' contribute nothing; a+-- 'TInpCtorField' for the matching 'InCtor' contributes its+-- '(Index, value)' pair. Since EP-47 the /derived/ fields+-- ('TArith'\/'TApp1'\/'TApp2') are /skipped/ (they contribute no+-- entries) rather than aborting the walk — 'solveOutput' verifies them+-- forward afterwards. Returns 'Nothing' only on a genuinely malformed+-- edge: a 'TInpCtorField' naming a /different/ 'InCtor' (a runtime+-- diagnostic; soundness no longer depends on it — see below). 'assemble+-- []' for an empty 'ifs' is 'Just RNil', so empty-payload input+-- constructors recover trivially; and if a derived field is the /only/+-- place a command slot is read, the skipped slot leaves 'assemble'+-- short and 'solveOutput' fails — exactly the hidden-input case that+-- 'checkHiddenInputs' flags at build time.+--+-- == Type-safe index recovery (EP-53)+--+-- Because 'OutFields' is indexed by the same input field schema @ifs@ as+-- the 'OPack''s 'InCtor', a top-level 'TInpCtorField' inside this+-- 'OutFields' carries an @'Index' ifs r@ /into the @OPack@'s schema by+-- construction/. So @'ByIndex' ix val@ type-checks directly — no+-- @unsafeCoerce@ — and a constructor whose field schema differs from the+-- 'OPack''s 'InCtor' is rejected at compile time rather than coerced at+-- run time. The @'icName' ic1 == 'icName' ic2@ guard is retained only as+-- a defensive runtime diagnostic for an 'OutFields' that names a+-- different (but same-schema) constructor.+gatherInpEntries ::+  forall rs ci ifs fs.+  OutFields rs ci ifs fs -> fs -> InCtor ci ifs -> Maybe [ByIndex ifs]+gatherInpEntries OFNil () _ic = Just []+gatherInpEntries (OFCons t rest) (v, fs) ic = do+  here <- stepOne t v ic+  more <- gatherInpEntries rest fs ic+  pure (here ++ more)+  where+    stepOne :: forall f. Term rs ci ifs f -> f -> InCtor ci ifs -> Maybe [ByIndex ifs]+    stepOne (TLit _) _val _ = Just []+    stepOne (TReg _) _val _ = Just []+    stepOne (TInpCtorField ic2 ix) val ic1+      | icName ic1 == icName ic2 = Just [ByIndex ix val]+      | otherwise = Nothing+    -- Derived fields are skipped here and verified forward by+    -- 'solveOutput' (EP-47 recompute-and-verify); they contribute no+    -- command information of their own.+    stepOne (TApp1 _ _) _val _ = Just []+    stepOne (TApp2 _ _ _) _val _ = Just []+    stepOne (TArith _ _ _) _val _ = Just []++-- | A diagnostic produced by 'checkHiddenInputs'.+data HiddenInputWarning = HiddenInputWarning+  { -- | Description of the edge's source (typically @show s@).+    hiwEdgeSource :: String,+    -- | Human-readable description of what's hidden.+    hiwReason :: String+  }+  deriving (Eq, Show)++-- | For every edge in the transducer, check whether the @output@ can+-- mechanically recover the input on replay. Specifically:+--+--   * If @output@ is @[]@ (an ε-edge), and @update@ reads the input+--     symbol, that contribution is silent on the wire and+--     unrecoverable.+--   * If @output@ is non-empty, the per-edge check groups the+--     'OPack's by 'InCtor' name (via 'icName') and computes the+--     *union* of slots visited across every 'OPack' naming the same+--     'InCtor'. If the union still leaves any of the 'InCtor''s+--     slots unvisited, the warning names the 'InCtor' and the+--     missing slot(s).+--+-- For length-1 edges this matches the legacy per-'OPack' check+-- (there is only one 'OPack' so the union is trivial). For length-2++-- edges the union strengthening means an 'InCtor' jointly recovered+-- by multiple 'OPack's in the same edge — none of which covers all+-- slots alone, but together they do — does *not* fire the warning.+--+-- The check is intentionally conservative: it flags candidates for+-- the author to inspect, not theorems.+checkHiddenInputs ::+  forall phi rs s ci co.+  (Bounded s, Enum s, Show s) =>+  SymTransducer phi rs s ci co ->+  [HiddenInputWarning]+checkHiddenInputs t =+  [ HiddenInputWarning+      { hiwEdgeSource = show s,+        hiwReason = formatHiddenInputReason n r+      }+  | s <- [minBound .. maxBound],+    (n, e) <- zip [(0 :: Int) ..] (edgesOut t s),+    r <- hiddenInputReasons e+  ]++-- | A structured reason an edge's output cannot mechanically recover its+-- input on replay. This is the single source of truth behind both+-- 'checkHiddenInputs' (which formats these into the legacy 'HiddenInputWarning'+-- strings via 'formatHiddenInputReason') and 'hiddenInputWarnings' (which lifts+-- each into a structured 'TransducerValidationWarning' carrying the typed source+-- vertex, the input-constructor name, and the missing slot names).+data HiddenInputReason+  = -- | An ε-edge (empty @output@) whose @update@ reads the input symbol,+    --       so the read information is silent on the wire.+    HirEpsilonReadsInput+  | -- | The named input constructor has declared slots the edge's output+    --       never recovers (after unioning every same-constructor 'OPack').+    --       Carries the constructor name and the missing slot names.+    HirUnionMiss String [String]+  deriving (Eq, Show)++-- | The per-edge hidden-input analysis, factored out of 'checkHiddenInputs'+-- so the legacy string warnings and the structured 'hiddenInputWarnings' share+-- one implementation. For an ε-edge it reports 'HirEpsilonReadsInput' iff the+-- update reads the input; for a non-empty output it groups 'OPack's by input+-- constructor name, unions the recovered slots, and reports a 'HirUnionMiss' for+-- any constructor with uncovered slots (first-seen order, deterministic).+hiddenInputReasons ::+  forall phi rs ci co s. Edge phi rs ci co s -> [HiddenInputReason]+hiddenInputReasons e = case output e of+  []+    | edgeReadsInput e -> [HirEpsilonReadsInput]+    | otherwise -> []+  outs ->+    [ HirUnionMiss icN missing+    | (icN, allSlots, visitedUnion) <- groupByInCtorName outs,+      let missing = allSlots \\ nub visitedUnion,+      not (null missing)+    ]+  where+    -- Walk the output list, accumulating per-InCtor (slot list, visited+    -- slots). First seen wins on the slot list; subsequent OPacks with the+    -- same InCtor name extend the visited list.+    groupByInCtorName ::+      [OutTerm rs ci co] -> [(String, [String], [String])]+    groupByInCtorName = foldl add []+      where+        add acc (OPack ic _ fields) =+          let icN = icName ic+              allSl = slotNamesOf ic+              visited = visitedSlotsOf ic fields+           in extend acc icN allSl visited++        extend [] icN allSl visited = [(icN, allSl, visited)]+        extend ((n, sl, v) : rest) icN allSl visited+          | n == icN = (n, sl, v ++ visited) : rest+          | otherwise = (n, sl, v) : extend rest icN allSl visited++    -- Slots of an OPack's named 'InCtor' that the supplied 'OutFields' walk+    -- recovers via a /top-level/ 'TInpCtorField'. Since EP-47 this does NOT+    -- descend into derived ('TApp1'\/'TApp2'\/'TArith') terms: a slot read+    -- only inside a derived field is a /hidden input/, so it is reported+    -- missing rather than counted as covered.+    visitedSlotsOf ::+      forall ifs fs.+      InCtor ci ifs -> OutFields rs ci ifs fs -> [String]+    visitedSlotsOf ic@InCtor {} fields = goFields fields+      where+        allSlots = slotNamesOf ic++        goFields :: forall fs'. OutFields rs ci ifs fs' -> [String]+        goFields OFNil = []+        goFields (OFCons tt rest) = goTerm tt ++ goFields rest++        goTerm :: forall r. Term rs ci ifs r -> [String]+        goTerm (TInpCtorField ic2 ix)+          | icName ic2 == icName ic =+              [allSlots !! indexPos ix]+          | otherwise = []+        goTerm _ = [] -- do not descend into derived terms+        indexPos :: forall rs' r. Index rs' r -> Int+        indexPos ZIdx = 0+        indexPos (SIdx i) = 1 + indexPos i++-- | Format a 'HiddenInputReason' into the legacy 'HiddenInputWarning' reason+-- string. The output is byte-identical to the pre-refactor 'checkHiddenInputs'+-- text so existing consumers and tests are unaffected.+formatHiddenInputReason :: Int -> HiddenInputReason -> String+formatHiddenInputReason n HirEpsilonReadsInput =+  "edge #" <> show n <> ": ε-edge with input read in update"+formatHiddenInputReason n (HirUnionMiss icN missing) =+  "edge #"+    <> show n+    <> ": OPack walk for InCtor \""+    <> icN+    <> "\" leaves field"+    <> (if length missing == 1 then " " else "s ")+    <> "{"+    <> showMissing missing+    <> "} unrecovered"+  where+    showMissing :: [String] -> String+    showMissing [] = ""+    showMissing [x] = "\"" <> x <> "\""+    showMissing (x : xs) = "\"" <> x <> "\", " <> showMissing xs++-- | Does the 'Update' read the input symbol via 'TInpCtorField'?+updateReadsInput :: Update rs w ci -> Bool+updateReadsInput UKeep = False+updateReadsInput (USet _ t) = termReadsInput t+updateReadsInput (UCombine a b) = updateReadsInput a || updateReadsInput b++-- | Does the 'Term' read the input symbol via 'TInpCtorField'?+termReadsInput :: Term rs ci ifs r -> Bool+termReadsInput (TLit _) = False+termReadsInput (TReg _) = False+termReadsInput (TInpCtorField _ _) = True+termReadsInput (TApp1 _ t) = termReadsInput t+termReadsInput (TApp2 _ a b) = termReadsInput a || termReadsInput b+termReadsInput (TArith _ a b) = termReadsInput a || termReadsInput b++-- | Do the 'OutFields' contain a 'TInpCtorField' read anywhere?+outFieldsHaveInpCtorField :: OutFields rs ci ifs fs -> Bool+outFieldsHaveInpCtorField OFNil = False+outFieldsHaveInpCtorField (OFCons t rest) =+  termHasInpCtorField t || outFieldsHaveInpCtorField rest+  where+    termHasInpCtorField :: Term rs ci ifs r -> Bool+    termHasInpCtorField (TLit _) = False+    termHasInpCtorField (TReg _) = False+    termHasInpCtorField (TInpCtorField _ _) = True+    termHasInpCtorField (TApp1 _ t') = termHasInpCtorField t'+    termHasInpCtorField (TApp2 _ a b) = termHasInpCtorField a || termHasInpCtorField b+    termHasInpCtorField (TArith _ a b) = termHasInpCtorField a || termHasInpCtorField b++-- | The result of 'detectMissingInCtorFields': the offending 'InCtor'+-- name plus the names of slots its 'OutFields' walk does not visit.+data MissingInCtorFields = MissingInCtorFields+  { mifIcName :: String,+    mifMissing :: [String]+  }+  deriving (Eq, Show)++-- | Given the 'InCtor' an 'OPack' is tagged with and that 'OPack'\'s+-- 'OutFields', return the field names of the 'InCtor' that the+-- 'OutFields' walk does not visit. 'Nothing' means every slot of the+-- 'InCtor' is visited. The slot list comes from the 'InCtor' itself+-- (via 'KnownSlotNames'), not from any 'TInpCtorField' inside the+-- 'OutFields' — this lets us flag empty 'OutFields' against a non-+-- empty 'InCtor' as well.+detectMissingInCtorFields ::+  forall rs ci ifs fs.+  InCtor ci ifs ->+  OutFields rs ci ifs fs ->+  Maybe MissingInCtorFields+detectMissingInCtorFields ic@InCtor {} fields =+  case allSlots \\ nub visited of+    [] -> Nothing+    missing -> Just (MissingInCtorFields (icName ic) missing)+  where+    allSlots = slotNamesOf ic+    visited = goFields fields++    goFields :: forall fs'. OutFields rs ci ifs fs' -> [String]+    goFields OFNil = []+    goFields (OFCons t rest) = goTerm t ++ goFields rest++    goTerm :: forall r. Term rs ci ifs r -> [String]+    goTerm (TInpCtorField ic2 ix)+      | icName ic2 == icName ic =+          [allSlots !! indexPos ix]+      | otherwise = []+    goTerm _ = [] -- EP-47: top-level reads only; derived+    -- (TApp/TArith) terms are not descended+    -- into, so a slot read only inside one is+    -- reported missing (a hidden input).+    indexPos :: forall rs' r. Index rs' r -> Int+    indexPos ZIdx = 0+    indexPos (SIdx i) = 1 + indexPos i++-- | Read the slot-name list out of an 'InCtor' (uses the+-- 'KnownSlotNames' instance carried by the data constructor).+slotNamesOf :: forall ci ifs. InCtor ci ifs -> [String]+slotNamesOf InCtor {} = slotNames @ifs++-- * Build-time validation umbrella (EP-56) --------------------------------++-- | A structured build-time validation warning, parameterized over the+-- vertex type @s@ so it carries the real source vertex rather than a+-- pre-stringified one. It reuses the canonical 'EdgeRef' locator owned by EP-55+-- (the runtime explainer 'stepEither'), so the runtime and build-time+-- diagnostics speak one vocabulary.+--+-- Produced by 'validateTransducer'. The three kinds correspond to the three+-- authoring mistakes the consumer audit flagged: hidden replay inputs,+-- nondeterministic (overlapping) guards, and edges that can never fire.+data TransducerValidationWarning s+  = -- | An edge consumes command information that its output does not+    --       emit, so the command cannot be reconstructed on replay.+    HiddenInput+      { tvwEdge :: EdgeRef s,+        -- | input constructor name, when known+        tvwInCtor :: Maybe String,+        -- | slot/field names left off the wire+        tvwMissingSlots :: [String],+        -- | human-readable summary+        tvwDetail :: String+      }+  | -- | Two outgoing edges of the same vertex whose guards can both hold+    --       for one command — a runtime nondeterminism / single-valuedness+    --       violation (its dynamic witness is EP-55's @AmbiguousEdges@).+    NondeterministicPair+      { tvwSource :: s,+        tvwEdgeA :: Int,+        tvwEdgeB :: Int,+        tvwInCtor :: Maybe String,+        tvwDetail :: String+      }+  | -- | An edge that can never fire: its source vertex is unreachable+    --       from 'initial', or its guard is statically unsatisfiable. Labelled+    --       "possibly" because the structural pass is conservative.+    PossiblyDeadEdge+      { tvwEdge :: EdgeRef s,+        tvwDetail :: String+      }+  | -- | An edge whose guard contains an opaque 'TApp' term. The symbolic+    --       single-valuedness and dead-edge analyses translate such a term to an+    --       unconstrained free variable ('Keiki.Symbolic.translateTermSym' emits+    --       @SBV.free "app1"@), so they cannot see through the guard and silently+    --       under-verify it. Most often this is a collection-content condition+    --       (membership, "all resolved", size) lifted through a closure because the+    --       structural predicate language has no node for it; see the user guide and+    --       @docs\/plans\/60-first-class-collection-registers-design-gated.md@ for the+    --       options. Advisory, not a soundness error: opt in via 'warnOpaqueGuards'.+    OpaqueGuard+      { tvwEdge :: EdgeRef s,+        tvwDetail :: String+      }+  deriving stock (Eq, Show)++-- | Which checks 'validateTransducer' runs. All default to 'True' (see+-- 'defaultValidationOptions').+data ValidationOptions = ValidationOptions+  { -- | run the hidden-input check+    failOnEpsilonReadsInput :: Bool,+    -- | run the (pure, structural) determinism check+    checkDeterminism :: Bool,+    -- | run the (structural) dead-edge check+    checkReachability :: Bool,+    -- | run the opaque-guard audit (opt-in; default off). Flags edges whose+    --     guard branches on an opaque 'TApp' term the symbolic analyses cannot+    --     see through. Off by default so 'defaultValidationOptions' keeps its+    --     meaning for existing consumers.+    warnOpaqueGuards :: Bool+  }+  deriving stock (Eq, Show)++-- | The three soundness checks enabled; the opt-in opaque-guard audit off.+defaultValidationOptions :: ValidationOptions+defaultValidationOptions =+  ValidationOptions+    { failOnEpsilonReadsInput = True,+      checkDeterminism = True,+      checkReachability = True,+      warnOpaqueGuards = False+    }++-- | The build-time validation umbrella. Runs the enabled checks over the+-- 'HsPred' (syntactic, /no solver/) carrier and concatenates their structured+-- warnings, so a project can put @validateTransducer defaultValidationOptions t+-- == []@ directly in a unit test and have it pass or fail in microseconds with+-- no external z3 process.+--+-- The default path is deliberately specialised to the 'HsPred' carrier and is+-- /cheap and pure/: the determinism component flags only structurally-provable+-- overlaps (never a false positive, but it can miss overlaps it cannot prove+-- syntactically), and the dead-edge component is structural reachability plus a+-- literal-'PBot' check. For the exact, solver-backed answers use+-- 'Keiki.Symbolic.checkTransitionDeterminismSym' and+-- 'Keiki.Symbolic.checkDeadEdgesSym' directly.+validateTransducer ::+  (Bounded s, Enum s, Ord s, Show s) =>+  ValidationOptions ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  [TransducerValidationWarning s]+validateTransducer opts t =+  concat+    [ if failOnEpsilonReadsInput opts then hiddenInputWarnings t else [],+      if checkDeterminism opts then determinismWarnings t else [],+      if checkReachability opts+        then+          [ PossiblyDeadEdge (dewEdge w) (dewReason w)+          | w <- checkDeadEdges defaultDeadEdgeOptions t+          ]+        else [],+      if warnOpaqueGuards opts then opaqueGuardWarnings t else []+    ]++-- | Structured form of the hidden-input check, additive over+-- 'checkHiddenInputs'. Reuses the same per-edge analysis ('hiddenInputReasons')+-- and lifts each result into a 'TransducerValidationWarning' carrying the typed+-- source vertex (via 'EdgeRef'), the input-constructor name, and the missing+-- slot names — data a downstream project can pattern-match on rather than parse+-- out of a string.+hiddenInputWarnings ::+  (Bounded s, Enum s) =>+  SymTransducer phi rs s ci co ->+  [TransducerValidationWarning s]+hiddenInputWarnings t =+  [ HiddenInput+      { tvwEdge = EdgeRef {edgeSource = s, edgeIndex = n},+        tvwInCtor = inCtorOf r,+        tvwMissingSlots = missingSlotsOf r,+        tvwDetail = formatHiddenInputReason n r+      }+  | s <- [minBound .. maxBound],+    (n, e) <- zip [(0 :: Int) ..] (edgesOut t s),+    r <- hiddenInputReasons e+  ]+  where+    inCtorOf (HirUnionMiss icN _) = Just icN+    inCtorOf HirEpsilonReadsInput = Nothing+    missingSlotsOf (HirUnionMiss _ ms) = ms+    missingSlotsOf HirEpsilonReadsInput = []++-- ** Opaque-guard diagnostics++-- | Does the term contain an opaque 'TApp1'\/'TApp2' anywhere? Mirrors the+-- structural recursion of 'termReadsInput'; 'TArith' is transparent, so it+-- recurses into its operands rather than counting as opaque.+termHasOpaqueApp :: Term rs ci ifs r -> Bool+termHasOpaqueApp (TLit _) = False+termHasOpaqueApp (TReg _) = False+termHasOpaqueApp (TInpCtorField _ _) = False+termHasOpaqueApp (TApp1 _ _) = True+termHasOpaqueApp (TApp2 _ _ _) = True+termHasOpaqueApp (TArith _ a b) = termHasOpaqueApp a || termHasOpaqueApp b++-- | Does the guard predicate branch on an opaque term anywhere? The symbolic+-- analyses cannot see through such a guard (it becomes a free SBV variable),+-- so they silently under-verify the edge.+predHasOpaqueTerm :: HsPred rs ci -> Bool+predHasOpaqueTerm PTop = False+predHasOpaqueTerm PBot = False+predHasOpaqueTerm (PAnd p q) = predHasOpaqueTerm p || predHasOpaqueTerm q+predHasOpaqueTerm (POr p q) = predHasOpaqueTerm p || predHasOpaqueTerm q+predHasOpaqueTerm (PNot p) = predHasOpaqueTerm p+predHasOpaqueTerm (PEq a b) = termHasOpaqueApp a || termHasOpaqueApp b+predHasOpaqueTerm (PInCtor _) = False+predHasOpaqueTerm (PCmp _ a b) = termHasOpaqueApp a || termHasOpaqueApp b++-- | The opt-in opaque-guard audit (run by 'validateTransducer' only when+-- 'warnOpaqueGuards' is set). For every edge whose guard contains an opaque+-- 'TApp' term, emit an 'OpaqueGuard' warning locating the edge by its typed+-- 'EdgeRef'. Specialised to the 'HsPred' carrier because it walks the predicate+-- AST, exactly as 'validateTransducer' is.+opaqueGuardWarnings ::+  (Bounded s, Enum s) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  [TransducerValidationWarning s]+opaqueGuardWarnings t =+  [ OpaqueGuard+      { tvwEdge = EdgeRef {edgeSource = s, edgeIndex = n},+        tvwDetail =+          "guard contains an opaque TApp term the symbolic analyses cannot "+            ++ "see through; its single-valuedness was not verified"+      }+  | s <- [minBound .. maxBound],+    (n, e) <- zip [(0 :: Int) ..] (edgesOut t s),+    predHasOpaqueTerm (guard e)+  ]++-- ** Determinism diagnostics++-- | A determinism warning: two outgoing edges of the same vertex whose guards+-- can both hold. Carries both edge indices and the (typed) source vertex.+data DeterminismWarning s = DeterminismWarning+  { dwSource :: s,+    -- | first overlapping edge index+    dwEdgeA :: Int,+    -- | second overlapping edge index+    dwEdgeB :: Int,+    dwDetail :: String+  }+  deriving stock (Eq, Show)++-- | Per-vertex, per-pair determinism diagnostic. Reuses the exact pairing+-- structure of 'Keiki.Symbolic.isSingleValuedSym': for every vertex, for every+-- pair @(i,e1),(j,e2)@ with @i<j@, the pair is ambiguous when+-- @guard e1 \`conj\` guard e2@ is /not/ 'isBot'. So+-- @checkTransitionDeterminism t == []@ iff @isSingleValuedSym t@ under the same+-- carrier.+--+-- Soundness direction: with the pure 'HsPred' carrier, 'isBot' only recognises+-- the literal 'PBot', so @not (isBot (a \`conj\` b))@ holds for /every/ non-'PBot'+-- pair — i.e. this polymorphic check over-approximates overlap on the 'HsPred'+-- carrier (it would flag almost every multi-edge vertex). It is intended to be+-- run over the /symbolic/ 'SymPred' carrier (via+-- 'Keiki.Symbolic.checkTransitionDeterminismSym'), whose 'isBot' is exact. For+-- the pure path 'validateTransducer' uses the under-approximating+-- 'checkTransitionDeterminismPure' instead, which flags only true positives.+checkTransitionDeterminism ::+  forall phi rs s ci co.+  (BoolAlg phi (RegFile rs, ci), Bounded s, Enum s, Show s) =>+  SymTransducer phi rs s ci co ->+  [DeterminismWarning s]+checkTransitionDeterminism t =+  [ DeterminismWarning+      { dwSource = s,+        dwEdgeA = i,+        dwEdgeB = j,+        dwDetail = overlapDetail i j s+      }+  | s <- [minBound .. maxBound],+    let ies = zip [(0 :: Int) ..] (edgesOut t s),+    (i, e1) <- ies,+    (j, e2) <- ies,+    i < j,+    not (isBot (guard e1 `conj` guard e2))+  ]++-- | Over-approximation-free determinism check for the pure 'HsPred' carrier:+-- emits a warning only when overlap is structurally provable (both guards are+-- 'PTop', or both name the same input constructor). Used by 'validateTransducer'+-- so the pure path yields no false positives. Every warning it emits is a true+-- positive; the absence of a warning does NOT prove determinism — run+-- 'Keiki.Symbolic.checkTransitionDeterminismSym' for the exact answer.+checkTransitionDeterminismPure ::+  forall rs s ci co.+  (Bounded s, Enum s, Show s) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  [DeterminismWarning s]+checkTransitionDeterminismPure t =+  [ DeterminismWarning+      { dwSource = s,+        dwEdgeA = i,+        dwEdgeB = j,+        dwDetail = overlapDetail i j s+      }+  | s <- [minBound .. maxBound],+    let ies = zip [(0 :: Int) ..] (edgesOut t s),+    (i, e1) <- ies,+    (j, e2) <- ies,+    i < j,+    provablyOverlap (guard e1) (guard e2)+  ]++overlapDetail :: (Show s) => Int -> Int -> s -> String+overlapDetail i j s =+  "edges #"+    <> show i+    <> " and #"+    <> show j+    <> " out of "+    <> show s+    <> " have overlapping guards"++-- | Structurally-provable guard overlap for the pure 'HsPred' carrier: 'True'+-- only when overlap is certain (both 'PTop', or the same input constructor).+-- Conservative — never a false positive; misses overlaps it cannot prove+-- syntactically (those are left to the symbolic variant).+provablyOverlap :: HsPred rs ci -> HsPred rs ci -> Bool+provablyOverlap PTop PTop = True+provablyOverlap (PInCtor a) (PInCtor b) = icName a == icName b+provablyOverlap _ _ = False++-- | Internal: the determinism component of 'validateTransducer'. Like+-- 'checkTransitionDeterminismPure' but emits the richer 'NondeterministicPair'+-- directly, populating 'tvwInCtor' with the overlapping command constructor when+-- both guards name the same one (and 'Nothing' for the 'PTop' case).+determinismWarnings ::+  (Bounded s, Enum s, Show s) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  [TransducerValidationWarning s]+determinismWarnings t =+  [ NondeterministicPair+      { tvwSource = s,+        tvwEdgeA = i,+        tvwEdgeB = j,+        tvwInCtor = overlapCtor (guard e1) (guard e2),+        tvwDetail = overlapDetail i j s+      }+  | s <- [minBound .. maxBound],+    let ies = zip [(0 :: Int) ..] (edgesOut t s),+    (i, e1) <- ies,+    (j, e2) <- ies,+    i < j,+    provablyOverlap (guard e1) (guard e2)+  ]+  where+    overlapCtor (PInCtor a) (PInCtor b)+      | icName a == icName b = Just (icName a)+    overlapCtor _ _ = Nothing++-- ** Dead-edge diagnostics++-- | Options for 'checkDeadEdges'. 'deoFlagBotGuards' additionally flags edges+-- whose guard is literally 'PBot' (statically unsatisfiable), beyond edges+-- leaving unreachable vertices.+data DeadEdgeOptions = DeadEdgeOptions+  { deoFlagBotGuards :: Bool+  }+  deriving stock (Eq, Show)++-- | Flag both unreachable-source edges and literal-'PBot' guards.+defaultDeadEdgeOptions :: DeadEdgeOptions+defaultDeadEdgeOptions = DeadEdgeOptions {deoFlagBotGuards = True}++-- | A dead-edge warning: an edge locator and a human-readable reason it is+-- /possibly/ (never certainly) dead.+data DeadEdgeWarning s = DeadEdgeWarning+  { dewEdge :: EdgeRef s,+    dewReason :: String+  }+  deriving stock (Eq, Show)++-- | The set of vertices reachable from 'initial' by following 'target'+-- pointers. A finite fixpoint over the 'Bounded'\/'Enum' vertex set.+reachableVertices ::+  (Bounded s, Enum s, Ord s) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  Set.Set s+reachableVertices t = go (Set.singleton (initial t)) [initial t]+  where+    go seen [] = seen+    go seen (s : rest) =+      let succs = [target e | e <- edgesOut t s]+          new = filter (`Set.notMember` seen) succs+       in go (foldr Set.insert seen new) (new ++ rest)++-- | Structural, conservative dead-edge analysis. Flags an edge as possibly+-- dead when its source vertex is unreachable from 'initial' (so the edge can+-- never fire) or, optionally, when its guard is the literal 'PBot' (statically+-- unsatisfiable).+--+-- This is purely structural: it follows 'target' pointers and inspects guards+-- syntactically. It CANNOT reason about register values. A self-loop guarded+-- @available == True@ whose @available@ is set 'False' on entry is NOT catchable+-- here (its guard is not literal 'PBot' and its source vertex is reachable) —+-- only 'Keiki.Symbolic.checkDeadEdgesSym' (or a future full reachable-state+-- analysis) could. Therefore every result is labelled "possibly dead".+checkDeadEdges ::+  (Bounded s, Enum s, Ord s, Show s) =>+  DeadEdgeOptions ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  [DeadEdgeWarning s]+checkDeadEdges opts t =+  let reach = reachableVertices t+   in [ DeadEdgeWarning (EdgeRef {edgeSource = s, edgeIndex = i}) reason+      | s <- [minBound .. maxBound],+        (i, e) <- zip [(0 :: Int) ..] (edgesOut t s),+        reason <- deadReasons reach s e+      ]+  where+    deadReasons reach s e+      | s `Set.notMember` reach =+          ["source vertex " <> show s <> " is unreachable from initial"]+      | deoFlagBotGuards opts && isBotGuard (guard e) =+          ["guard is statically unsatisfiable (PBot)"]+      | otherwise = []+    isBotGuard PBot = True+    isBotGuard _ = False
+ src/Keiki/Decider.hs view
@@ -0,0 +1,119 @@+-- | A Chassaing-shape Decider façade over a 'SymTransducer'.+--+-- Users coming from the naive functional event-sourcing world+-- (Jérémie Chassaing's /Functional Event Sourcing Decider/) work+-- with a small record:+--+-- @+-- data Decider c e s = Decider+--   { decide       :: c -> s -> [e]+--   , evolve       :: s -> e -> s+--   , initialState :: s+--   , isTerminal   :: s -> Bool+--   }+-- @+--+-- 'toDecider' projects the keiki 'SymTransducer' onto this shape.+-- 'decide' is built on 'omega' (the forward step that emits one or+-- more events per command after the EP-19 widening); 'evolve' is+-- built on 'applyEvent' (the letter-only inverse step). With the+-- widened @'Keiki.Core.Edge.output' :: ['Keiki.Core.OutTerm' rs ci+-- co]@ a single command can yield two or more events end-to-end+-- without any state-refinement scaffolding — 'decide' returns the+-- full list directly. EP-19 retired the previous EP-20 façades+-- (@toMultiDecider@ + @DriverConfig@); the multi-event behaviour is+-- now first-class in the AST.+--+-- == Streaming replay through multi-event edges+--+-- The 'evolve' field is letter-only (handles edges with output of+-- length 0 or 1) and remains the canonical letter-replay verb.+-- Event-by-event streaming across a length-2+ edge passes through+-- the intermediate "I just observed event 1, expecting event 2 next"+-- state; the 'evolveStreaming' field exposes this via+-- 'Keiki.Core.InFlight' and 'Keiki.Core.applyEventStreaming'. The+-- two evolve fields agree on length-0/1 commands; they diverge+-- only on length-2+ where the streaming path stays /InFlight/+-- between events.+--+-- == One semantic gap remains+--+-- /ε-edges/ — edges whose @output@ is @[]@. The transducer+-- transitions state without emitting an event. 'decide' returns+-- @[]@ for such commands, and the result is identical to "no event+-- happened" from the Decider record's perspective. Use+-- 'Keiki.Core.delta' / 'Keiki.Core.step' directly when ε-driven+-- transitions matter.+module Keiki.Decider+  ( Decider (..),+    toDecider,+  )+where++import Keiki.Core+  ( BoolAlg,+    InFlight (..),+    RegFile,+    SymTransducer (..),+    applyEvent,+    applyEventStreaming,+    omega,+  )++-- | The Chassaing-shape Decider record. Field selectors are named+-- to match published Decider examples; conflicts with other modules+-- are avoided by importing this module qualified.+--+-- The @s_streaming@ parameter carries the InFlight-aware streaming+-- state ('Keiki.Core.InFlight' s co paired with a register file);+-- for letter-only callers it is unused.+data Decider c e s s_streaming = Decider+  { decide :: c -> s -> [e],+    evolve :: s -> e -> s,+    evolveStreaming :: s_streaming -> e -> Maybe s_streaming,+    initialState :: s,+    isTerminal :: s -> Bool+  }++-- | Project a keiki 'SymTransducer' to a 'Decider' record. The+-- letter-replay state carrier is @(s, RegFile rs)@ and the+-- streaming-replay state carrier is @('Keiki.Core.InFlight' s co,+-- RegFile rs)@ — keiki edge guards depend on the register file as+-- well as the control vertex, and streaming replay through a+-- length-2+ edge intrinsically observes a mid-chain wrapper.+--+-- == Field-by-field correspondence+--+-- @+-- decide d cmd (s, regs)        -- = omega t s regs cmd            (EP-19 widened)+-- evolve d (s, regs) ev         -- = letter-only applyEvent;+--                               --   on length-2+ edges, falls back+--                               --   to the input state defensively+-- evolveStreaming d ws ev       -- = applyEventStreaming, returning+--                               --   the wrapped state mid-chain+-- initialState d                -- = (initial t, initialRegs t)+-- isTerminal   d (s, _regs)     -- = isFinal t s+-- @+--+-- == Defensive 'evolve'+--+-- 'applyEvent' returns 'Nothing' when an event cannot be replayed+-- letter-by-letter from @(s, regs)@. To keep the Chassaing signature+-- non-'Maybe', 'evolve' returns the input state on failure. Callers+-- that want strict replay use 'evolveStreaming' (whose 'Maybe' is+-- explicit) or 'Keiki.Core.applyEvents' (which returns 'Nothing' on+-- the first replay failure across a chunk).+toDecider ::+  (BoolAlg phi (RegFile rs, ci), Eq co) =>+  SymTransducer phi rs s ci co ->+  Decider ci co (s, RegFile rs) (InFlight s co, RegFile rs)+toDecider t =+  Decider+    { decide = \cmd (s, regs) -> omega t s regs cmd,+      evolve = \(s, regs) ev -> case applyEvent t s regs ev of+        Just (s', regs') -> (s', regs')+        Nothing -> (s, regs),+      evolveStreaming = \(w, regs) ev -> applyEventStreaming t w regs ev,+      initialState = (initial t, initialRegs t),+      isTerminal = \(s, _regs) -> isFinal t s+    }
+ src/Keiki/Generics.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE TypeFamilies #-}++-- | DX spike (EP-2 follow-up): generic-derived inversions between+-- Haskell records and 'RegFile's so users can build 'InCtor' values+-- without hand-rolling RCons-towers.+--+-- Status: experimental. See the EP-2 retrospective for context.+module Keiki.Generics+  ( -- * Generic-derived InCtor+    mkInCtor,+    mkInCtor0,+    mkInCtorVia,++    -- * Generic-derived WireCtor+    mkWireCtor,+    mkWireCtor0,+    mkWireCtorVia,+    FieldsOf,+    FieldsOfRep,++    -- * Slot-list deriving+    RegFieldsOf,+    RegFieldsOfRep,++    -- * Empty register file+    EmptyRegFile (..),++    -- * Sum-walking machinery+    GHasCtor (..),+    GHasCtorIf (..),+    NameInRep,++    -- * Internals+    GRecord (..),+    GTuple (..),+    Append,+    appendRegFile,+    SplitRegFile (..),+    ConcatT,+    SplitT (..),+  )+where++import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Type.Bool (type (||))+import GHC.Generics+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Keiki.Core++-- | Walk a 'GHC.Generics' record representation to/from a 'RegFile'.+-- Slot lists are derived from the record's field metadata: every+-- selector @M1 S ('MetaSel ('Just name) ...)@ contributes a slot+-- @'(name, fieldType)@; products concatenate.+class GRecord (rep :: Type -> Type) (ifs :: [Slot]) | rep -> ifs where+  gToRegFile :: rep a -> RegFile ifs+  gFromRegFile :: RegFile ifs -> rep a++-- M1 D wrapper (data type metadata): pass through.+instance (GRecord inner ifs) => GRecord (M1 D meta inner) ifs where+  gToRegFile (M1 r) = gToRegFile r+  gFromRegFile rf = M1 (gFromRegFile rf)++-- M1 C wrapper (constructor metadata): pass through.+instance (GRecord inner ifs) => GRecord (M1 C meta inner) ifs where+  gToRegFile (M1 r) = gToRegFile r+  gFromRegFile rf = M1 (gFromRegFile rf)++-- Named selector with a leaf field: one slot.+instance+  (KnownSymbol name) =>+  GRecord+    (M1 S ('MetaSel ('Just name) su ss ds) (K1 r t))+    '[ '(name, t)]+  where+  gToRegFile (M1 (K1 v)) = RCons (Proxy @name) v RNil+  gFromRegFile (RCons _ v _) = M1 (K1 v)++-- No-arg constructor: empty slot list.+instance GRecord U1 '[] where+  gToRegFile U1 = RNil+  gFromRegFile RNil = U1++-- Product: concatenate slot lists.+instance+  ( GRecord l ls,+    GRecord r rs,+    Append ls rs ~ ifs,+    SplitRegFile ls rs+  ) =>+  GRecord (l :*: r) ifs+  where+  gToRegFile (a :*: b) = appendRegFile (gToRegFile a) (gToRegFile b)+  gFromRegFile rf = case splitRegFile @ls @rs rf of+    (lrf, rrf) -> gFromRegFile lrf :*: gFromRegFile rrf++-- | Type-level append for slot lists.+type family Append (xs :: [Slot]) (ys :: [Slot]) :: [Slot] where+  Append '[] ys = ys+  Append (x ': xs) ys = x ': Append xs ys++-- | Value-level append for register files.+appendRegFile :: RegFile ls -> RegFile rs -> RegFile (Append ls rs)+appendRegFile RNil rs = rs+appendRegFile (RCons p v xs) rs = RCons p v (appendRegFile xs rs)++-- | Split a register file at the boundary between two slot lists.+class SplitRegFile (ls :: [Slot]) (rs :: [Slot]) where+  splitRegFile :: RegFile (Append ls rs) -> (RegFile ls, RegFile rs)++instance SplitRegFile '[] rs where+  splitRegFile rf = (RNil, rf)++instance (SplitRegFile ls rs) => SplitRegFile ('(s, t) ': ls) rs where+  splitRegFile (RCons p v rest) =+    case splitRegFile @ls @rs rest of+      (lrf, rrf) -> (RCons p v lrf, rrf)++-- | Build an 'InCtor' from a constructor name, a sum-side matcher,+-- and a pack function. The 'RegFile' inversion is derived from the+-- record's 'GHC.Generics.Generic' instance — no RCons-tower required.+--+-- Example:+--+-- > inCtorStart :: InCtor UserCmd+-- >                       '[ '("email",       Email)+-- >                        , '("confirmCode", ConfirmationCode)+-- >                        , '("at",          UTCTime)+-- >                        ]+-- > inCtorStart = mkInCtor "StartRegistration"+-- >                        (\case StartRegistration d -> Just d; _ -> Nothing)+-- >                        StartRegistration+--+-- The slot list is inferred from @StartRegistrationData@'s 'Generic'+-- field metadata. The record type must have @deriving (Generic)@.+mkInCtor ::+  forall ci d ifs.+  ( Generic d,+    GRecord (Rep d) ifs,+    AssembleRegFile ifs,+    KnownSlotNames ifs+  ) =>+  String ->+  (ci -> Maybe d) ->+  (d -> ci) ->+  InCtor ci ifs+mkInCtor name match wrap =+  InCtor+    { icName = name,+      icMatch = \ci -> case match ci of+        Just d -> Just (gToRegFile (from d))+        Nothing -> Nothing,+      icBuild = \rf -> wrap (to (gFromRegFile rf))+    }++-- | Build an 'InCtor' for a no-payload (singleton) constructor. The+-- 'icMatch' compares against the named singleton via 'Eq'; 'icBuild'+-- ignores the empty 'RegFile' and returns the singleton.+--+-- Example:+--+-- > inCtorContinue :: InCtor UserCmd '[]+-- > inCtorContinue = mkInCtor0 "Continue" Continue+mkInCtor0 :: forall ci. (Eq ci) => String -> ci -> InCtor ci '[]+mkInCtor0 name singleton =+  InCtor+    { icName = name,+      icMatch = \ci -> if ci == singleton then Just RNil else Nothing,+      icBuild = \RNil -> singleton+    }++-- * Generic-derived WireCtor ----------------------------------------------++-- | Walk a 'GHC.Generics' record representation to/from the nested-+-- pair tuple shape that 'WireCtor' / 'OutFields' carry. A record with+-- fields @f1, f2, f3@ corresponds to the tuple @(f1, (f2, (f3, ())))@.+class GTuple (rep :: Type -> Type) (fs :: Type) | rep -> fs where+  gToTuple :: rep a -> fs+  gFromTuple :: fs -> rep a++instance (GTuple inner fs) => GTuple (M1 D meta inner) fs where+  gToTuple (M1 r) = gToTuple r+  gFromTuple t = M1 (gFromTuple t)++instance (GTuple inner fs) => GTuple (M1 C meta inner) fs where+  gToTuple (M1 r) = gToTuple r+  gFromTuple t = M1 (gFromTuple t)++instance GTuple (M1 S meta (K1 r t)) (t, ()) where+  gToTuple (M1 (K1 v)) = (v, ())+  gFromTuple (v, ()) = M1 (K1 v)++instance GTuple U1 () where+  gToTuple U1 = ()+  gFromTuple () = U1++instance+  ( GTuple l ls,+    GTuple r rs,+    ConcatT ls rs ~ fs,+    SplitT ls rs+  ) =>+  GTuple (l :*: r) fs+  where+  gToTuple (a :*: b) = appendT (gToTuple a) (gToTuple b)+  gFromTuple t = case splitT @ls @rs t of+    (lt, rt) -> gFromTuple lt :*: gFromTuple rt++-- | Type-level concat for nested-pair tuples. @ConcatT (f1, (f2, ())) (f3, ()) ~ (f1, (f2, (f3, ())))@.+type family ConcatT (a :: Type) (b :: Type) :: Type where+  ConcatT () b = b+  ConcatT (x, xs) b = (x, ConcatT xs b)++-- | Split a concatenated nested-pair tuple back into its halves; also+-- the inverse direction (append).+class SplitT (a :: Type) (b :: Type) where+  splitT :: ConcatT a b -> (a, b)+  appendT :: a -> b -> ConcatT a b++instance SplitT () b where+  splitT b = ((), b)+  appendT () b = b++instance (SplitT xs b) => SplitT (x, xs) b where+  splitT (x, rest) = case splitT @xs @b rest of+    (a, c) -> ((x, a), c)+  appendT (x, xs) b = (x, appendT xs b)++-- | Resolve a record type to its nested-pair field tuple. With this+-- alias, @WireCtor UserEvent (FieldsOf RegistrationStartedData)@+-- replaces the hand-written @WireCtor UserEvent (Email,+-- (ConfirmationCode, (UTCTime, ())))@.+type FieldsOf d = FieldsOfRep (Rep d)++-- | The nested-pair tuple shape derived from a 'GHC.Generics' Rep.+type family FieldsOfRep (rep :: Type -> Type) :: Type where+  FieldsOfRep (M1 D _ inner) = FieldsOfRep inner+  FieldsOfRep (M1 C _ inner) = FieldsOfRep inner+  FieldsOfRep (M1 S _ (K1 _ t)) = (t, ())+  FieldsOfRep U1 = ()+  FieldsOfRep (l :*: r) = ConcatT (FieldsOfRep l) (FieldsOfRep r)++-- | Resolve a record type to its 'RegFile' slot list. With this+-- alias, @InCtor UserCmd (RegFieldsOf StartRegistrationData)@+-- replaces the hand-written @InCtor UserCmd '[ '("email", Email),+-- '("confirmCode", ConfirmationCode), '("at", UTCTime) ]@.+type RegFieldsOf d = RegFieldsOfRep (Rep d)++-- | The slot-list shape derived from a 'GHC.Generics' Rep. Mirrors+-- 'FieldsOfRep' but emits @[Slot]@ instead of a nested-pair tuple,+-- preserving the selector name on every field.+type family RegFieldsOfRep (rep :: Type -> Type) :: [Slot] where+  RegFieldsOfRep (M1 D _ inner) = RegFieldsOfRep inner+  RegFieldsOfRep (M1 C _ inner) = RegFieldsOfRep inner+  RegFieldsOfRep (M1 S ('MetaSel ('Just n) _ _ _) (K1 _ t)) =+    '[ '(n, t)]+  RegFieldsOfRep U1 = '[]+  RegFieldsOfRep (l :*: r) =+    Append+      (RegFieldsOfRep l)+      (RegFieldsOfRep r)++-- | Build a 'WireCtor' from a constructor name, a sum-side matcher,+-- and a pack function. The nested-pair conversion is derived from the+-- record's 'GHC.Generics.Generic' instance.+--+-- Example:+--+-- > wireRegistrationStarted+-- >   :: WireCtor UserEvent (FieldsOf RegistrationStartedData)+-- > wireRegistrationStarted = mkWireCtor "RegistrationStarted"+-- >   (\case RegistrationStarted d -> Just d; _ -> Nothing)+-- >   RegistrationStarted+mkWireCtor ::+  forall co d fs.+  ( Generic d,+    GTuple (Rep d) fs+  ) =>+  String ->+  (co -> Maybe d) ->+  (d -> co) ->+  WireCtor co fs+mkWireCtor name match wrap =+  WireCtor+    { wcName = name,+      wcMatch = \co -> case match co of+        Just d -> Just (gToTuple (from d))+        Nothing -> Nothing,+      wcBuild = \fs -> wrap (to (gFromTuple fs))+    }++-- | Build a 'WireCtor' for a no-payload (singleton) event constructor —+-- the event-side twin of 'mkInCtor0'. Its field tuple is @()@ (a+-- payload-free event carries nothing), matching @'OutFields' rs ci ()@ /+-- @OFNil@. 'wcMatch' compares against the named singleton via 'Eq';+-- 'wcBuild' ignores the empty tuple and returns the singleton. The+-- @'Eq' co@ constraint matches 'mkInCtor0'\'s @'Eq' ci@; event sums in+-- this codebase already derive 'Eq', so it is not a new burden.+--+-- Example:+--+-- > wireOpened :: WireCtor DoorEvent ()+-- > wireOpened = mkWireCtor0 "Opened" Opened+mkWireCtor0 :: forall co. (Eq co) => String -> co -> WireCtor co ()+mkWireCtor0 name singleton =+  WireCtor+    { wcName = name,+      wcMatch = \co -> if co == singleton then Just () else Nothing,+      wcBuild = \() -> singleton+    }++-- * Empty register file ---------------------------------------------------++-- | Derive an initial 'RegFile' for any slot list. Every slot is+-- pre-bound to a deferred error tagged with the slot's name so reads+-- of an uninitialized slot crash with a targeted message instead of+-- a silent bottom.+class EmptyRegFile (rs :: [Slot]) where+  emptyRegFile :: RegFile rs++instance EmptyRegFile '[] where+  emptyRegFile = RNil++instance+  (KnownSymbol s, EmptyRegFile rs) =>+  EmptyRegFile ('(s, r) ': rs)+  where+  emptyRegFile =+    RCons+      (Proxy @s)+      (error ("uninit: " ++ symbolVal (Proxy @s)))+      emptyRegFile++-- * Sum-walking machinery -------------------------------------------------++-- | Does the constructor named @n@ appear anywhere in the 'Generic'+-- representation @rep@? Used to dispatch sum-side resolution to the+-- correct branch.+type family NameInRep (n :: Symbol) (rep :: Type -> Type) :: Bool where+  NameInRep n (M1 D _ inner) = NameInRep n inner+  NameInRep n (l :+: r) = NameInRep n l || NameInRep n r+  NameInRep n (M1 C ('MetaCons n _ _) _) = 'True+  NameInRep _ _ = 'False++-- | Walk a 'Generic' representation looking for a constructor named+-- @name@; resolve its payload type @d@. Two payload shapes are+-- supported:+--+--   * @M1 C ('MetaCons name _ _) (M1 S _ (K1 _ d))@ — single-field+--     constructor wrapping a record value of type @d@.+--   * @M1 C ('MetaCons name _ _) U1@ — no-payload constructor;+--     @d ~ ()@.+--+-- The functional dependency @name rep -> d@ pins the payload uniquely.+class+  GHasCtor (name :: Symbol) (rep :: Type -> Type) (d :: Type)+    | name rep -> d+  where+  gMatchCtor :: rep a -> Maybe d+  gBuildCtor :: d -> rep a++-- Pass through the data-type wrapper.+instance (GHasCtor n inner d) => GHasCtor n (M1 D meta inner) d where+  gMatchCtor (M1 r) = gMatchCtor @n r+  gBuildCtor d = M1 (gBuildCtor @n d)++-- Match a constructor whose payload is a single record value.+instance GHasCtor n (M1 C ('MetaCons n fix lazy) (M1 S meta (K1 r d))) d where+  gMatchCtor (M1 (M1 (K1 d))) = Just d+  gBuildCtor d = M1 (M1 (K1 d))++-- Match a no-payload constructor; payload is the unit type '()'.+instance GHasCtor n (M1 C ('MetaCons n fix lazy) U1) () where+  gMatchCtor (M1 U1) = Just ()+  gBuildCtor () = M1 U1++-- Sum dispatch: pick the side that contains the named constructor.+instance+  ( hasL ~ NameInRep n l,+    GHasCtorIf hasL n l r d+  ) =>+  GHasCtor n (l :+: r) d+  where+  gMatchCtor x = gMatchCtorIf @hasL @n @l @r x+  gBuildCtor d = gBuildCtorIf @hasL @n @l @r d++-- | Sum-dispatch helper: reduce 'GHasCtor' on @l :+: r@ to a+-- 'GHasCtor' on the side that contains the named constructor.+class+  GHasCtorIf+    (b :: Bool)+    (n :: Symbol)+    (l :: Type -> Type)+    (r :: Type -> Type)+    (d :: Type)+    | b n l r -> d+  where+  gMatchCtorIf :: (l :+: r) a -> Maybe d+  gBuildCtorIf :: d -> (l :+: r) a++instance (GHasCtor n l d) => GHasCtorIf 'True n l r d where+  gMatchCtorIf (L1 x) = gMatchCtor @n x+  gMatchCtorIf (R1 _) = Nothing+  gBuildCtorIf d = L1 (gBuildCtor @n d)++instance (GHasCtor n r d) => GHasCtorIf 'False n l r d where+  gMatchCtorIf (L1 _) = Nothing+  gMatchCtorIf (R1 x) = gMatchCtor @n x+  gBuildCtorIf d = R1 (gBuildCtor @n d)++-- * Generic-derived InCtor / WireCtor (Via builders) ----------------------++-- | Build an 'InCtor' from a constructor name alone. The sum-side+-- match\/wrap pair and the record-side RegFile inversion are both+-- derived from the 'Generic' representations of @ci@ and the inferred+-- payload @d@. With no-payload constructors (e.g. 'Continue') the+-- inferred slot list is @\'[]@.+--+-- Example:+--+-- > inCtorStart    :: InCtor UserCmd StartFields+-- > inCtorStart     = mkInCtorVia @"StartRegistration"+-- >+-- > inCtorContinue :: InCtor UserCmd '[]+-- > inCtorContinue  = mkInCtorVia @"Continue"+mkInCtorVia ::+  forall (name :: Symbol) ci d ifs.+  ( KnownSymbol name,+    Generic ci,+    GHasCtor name (Rep ci) d,+    Generic d,+    GRecord (Rep d) ifs,+    AssembleRegFile ifs,+    KnownSlotNames ifs+  ) =>+  InCtor ci ifs+mkInCtorVia =+  InCtor+    { icName = symbolVal (Proxy @name),+      icMatch = \ci -> case gMatchCtor @name (from ci) of+        Just d -> Just (gToRegFile (from d))+        Nothing -> Nothing,+      icBuild = \rf -> to (gBuildCtor @name (to (gFromRegFile rf) :: d))+    }++-- | Build a 'WireCtor' from a constructor name alone. Mirrors+-- 'mkInCtorVia' on the wire side: the nested-pair field tuple comes+-- from the inferred payload's 'Generic' field metadata.+--+-- Example:+--+-- > wireRegistrationStarted+-- >   :: WireCtor UserEvent (FieldsOf RegistrationStartedData)+-- > wireRegistrationStarted = mkWireCtorVia @"RegistrationStarted"+mkWireCtorVia ::+  forall (name :: Symbol) co d fs.+  ( KnownSymbol name,+    Generic co,+    GHasCtor name (Rep co) d,+    Generic d,+    GTuple (Rep d) fs+  ) =>+  WireCtor co fs+mkWireCtorVia =+  WireCtor+    { wcName = symbolVal (Proxy @name),+      wcMatch = \co -> case gMatchCtor @name (from co) of+        Just d -> Just (gToTuple (from d))+        Nothing -> Nothing,+      wcBuild = \fs -> to (gBuildCtor @name (to (gFromTuple fs) :: d))+    }
+ src/Keiki/Generics/TH.hs view
@@ -0,0 +1,1084 @@+{-# LANGUAGE TemplateHaskell #-}++-- \$('deriveAggregateCtors' \'\'UserCmd \'\'UserRegRegs+--     [ ("StartRegistration",  "Start")+--     , ("ConfirmAccount",     "Confirm")+--     , ("ResendConfirmation", "Resend")+--     , ("FulfillGDPRRequest", "Gdpr")+--     , ("Continue",           "Continue")+--     ])+-- @+--+-- expands to the same 14 declarations a hand-written module ships+-- (4 record ctors × 3 decls + 1 singleton × 2 decls).++-- | Template Haskell splices that retire the per-constructor authoring+-- boilerplate at the example layer.+--+-- 'deriveAggregateCtors' emits, for each entry in its spec list, the+-- three top-level declarations a command constructor needs in the+-- keiki DSL: an 'InCtor' value, an @inp@ field projection, and an+-- @is@ guard predicate. Singleton (no-payload) constructors get+-- 'InCtor' and the guard only — there is no field projection because+-- @'Index' '[]@ is uninhabited.+--+-- 'deriveWireCtors' is the dual on the event side, emitting one+-- 'WireCtor' value per spec entry and, for record-payload events, a+-- field-keyed @\<CtorName\>TermFields@ helper record.+--+-- 'deriveAggregateCtorsAll' and 'deriveWireCtorsAll' are the+-- zero-spec variants: they enumerate every constructor of the named+-- sum type and default each short-name suffix to the constructor's+-- own name, so the common "short name == constructor name" case needs+-- no hand-typed spec list. Keep the enumerated 'deriveAggregateCtors'+-- \/ 'deriveWireCtors' when you need an abbreviated short name that+-- differs from the constructor name.+--+-- 'deriveAggregate' is the fused all-in-one form: it bundles+-- 'deriveAggregateCtorsAll' and 'deriveWireCtorsAll' so an aggregate's+-- entire command- and event-side plumbing is a single splice.+--+-- Both splices read the constructor list of the named sum type via+-- 'reify' and dispatch on the constructor's payload shape: zero-arg+-- 'NormalC' is a singleton; one-arg 'NormalC' takes a record-payload+-- type. Record-syntax constructors ('RecC') and multi-arg 'NormalC'+-- are rejected with a precise error.+--+-- == Worked example+--+-- @+-- data UserCmd+--   = StartRegistration  StartRegistrationData+--   | ConfirmAccount     ConfirmAccountData+--   | ResendConfirmation ResendConfirmationData+--   | FulfillGDPRRequest FulfillGDPRRequestData+--   | Continue+--   deriving ('Eq', 'Show', 'GHC.Generics.Generic')+module Keiki.Generics.TH+  ( deriveAggregateCtors,+    deriveAggregateCtorsAll,+    deriveAggregateCtorsWith,+    DeriveCtorOptions (..),+    defaultDeriveCtorOptions,+    deriveWireCtors,+    deriveWireCtorsAll,+    deriveWireCtorsWith,+    DeriveWireOptions (..),+    defaultDeriveWireOptions,+    deriveAggregate,+    deriveView,+  )+where++import Data.Char (isUpper, toLower, toUpper)+import Data.List (group, nub, sort, (\\))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Keiki.Builder (ToOutFields (..))+import Keiki.Core+  ( HsPred,+    InCtor,+    Index,+    OutFields (..),+    RegFile,+    Term (..),+    WireCtor,+    matchInCtor,+    (!),+  )+import Keiki.Generics+  ( FieldsOf,+    RegFieldsOf,+    mkInCtor0,+    mkInCtorVia,+    mkWireCtor0,+    mkWireCtorVia,+  )+import Language.Haskell.TH++-- | Generate per-constructor @inCtor<Short>@, @inp<Short>@,+-- @is<Short>@ declarations from a command sum type and a register-file+-- slot list. Spec entries are @(constructorName, shortName)@ pairs;+-- the short name is appended to the @inCtor@/@inp@/@is@ prefix.+--+-- Singleton constructors (zero-arg 'NormalC') emit only @inCtor@ and+-- @is@; @inp@ is omitted because @'Index' '[]@ is uninhabited.+deriveAggregateCtors ::+  -- | command sum type, e.g. @\'\'UserCmd@+  Name ->+  -- | register-file slot list, e.g. @\'\'UserRegRegs@+  Name ->+  -- | pairs of (constructor name, short name)+  [(String, String)] ->+  Q [Dec]+deriveAggregateCtors cmdName regsName specs = do+  ctors <- reifyCtors cmdName "deriveAggregateCtors"+  let ctorMap = [(nameBase n, c) | c <- ctors, n <- conNames c]+  genAggregateCtors cmdName regsName ctorMap specs++-- | Like 'deriveAggregateCtors', but enumerate every constructor of the+-- command sum type automatically, using each constructor's own name as+-- its short-name suffix. Equivalent to calling 'deriveAggregateCtors'+-- with a spec list of @[(nameBase c, nameBase c) | c <- constructors]@,+-- so it generates @inCtor\<Ctor\>@, @inp\<Ctor\>@, and @is\<Ctor\>@ for+-- each constructor (singletons omit @inp\<Ctor\>@). Reach for the+-- enumerated 'deriveAggregateCtors' when you need an abbreviated short+-- name that differs from the constructor name.+deriveAggregateCtorsAll ::+  -- | command sum type, e.g. @\'\'OrderCmd@+  Name ->+  -- | register-file slot list, e.g. @\'\'OrderCartRegs@+  Name ->+  Q [Dec]+deriveAggregateCtorsAll cmdName regsName = do+  ctors <- reifyCtors cmdName "deriveAggregateCtorsAll"+  let ctorMap = [(nameBase n, c) | c <- ctors, n <- conNames c]+      specs = [(nameBase n, nameBase n) | c <- ctors, n <- conNames c]+  genAggregateCtors cmdName regsName ctorMap specs++-- | Options for 'deriveAggregateCtorsWith'.+--+-- 'suffixOverrides' maps a constructor name to the short-name suffix to+-- use for its generated helpers (e.g. @"DeclareIncident" -> "Declare"@+-- yields @inCtorDeclare@ \/ @inpDeclare@ \/ @isDeclare@). Constructors+-- absent from the map default to their own name as the suffix.+--+-- 'excludeCtors' names constructors to skip entirely: no helpers are+-- generated for them.+--+-- Every key in either field must be an actual constructor of the named+-- sum type; an unknown key aborts the splice at compile time.+data DeriveCtorOptions = DeriveCtorOptions+  { suffixOverrides :: Map String String,+    excludeCtors :: Set String+  }++-- | Default options: no overrides, no exclusions. With this, behaviour+-- is identical to 'deriveAggregateCtorsAll'.+defaultDeriveCtorOptions :: DeriveCtorOptions+defaultDeriveCtorOptions =+  DeriveCtorOptions+    { suffixOverrides = Map.empty,+      excludeCtors = Set.empty+    }++-- | Derive command-constructor helpers for every constructor of the+-- command sum type, like 'deriveAggregateCtorsAll', but honouring+-- per-constructor short-name overrides and an exclude set carried in+-- 'DeriveCtorOptions'. A constructor in 'suffixOverrides' uses the+-- mapped short name; otherwise it defaults to its own name; a+-- constructor in 'excludeCtors' is skipped entirely.+--+-- Unknown override\/exclude keys and duplicate resolved short names both+-- abort the splice at compile time with a precise message. For a+-- constructor present in 'suffixOverrides', the generated declarations+-- are byte-for-byte identical to what 'deriveAggregateCtors' produces+-- for the same @(constructor, short)@ pair.+deriveAggregateCtorsWith ::+  -- | command sum type, e.g. @\'\'IncidentCommand@+  Name ->+  -- | register-file slot list, e.g. @\'\'IncidentRegs@+  Name ->+  DeriveCtorOptions ->+  Q [Dec]+deriveAggregateCtorsWith cmdName regsName opts = do+  ctors <- reifyCtors cmdName "deriveAggregateCtorsWith"+  let ctorMap = [(nameBase n, c) | c <- ctors, n <- conNames c]+      allCtors = map fst ctorMap+  specs <-+    resolveCtorSpecs+      "deriveAggregateCtorsWith"+      allCtors+      (suffixOverrides opts)+      (excludeCtors opts)+  genAggregateCtors cmdName regsName ctorMap specs++-- | Generate per-constructor @wire<Short>@ declarations from an event+-- sum type. Spec entries are @(constructorName, shortName)@ pairs.+-- A record-payload event also gets a @\<Short\>TermFields@ helper+-- record plus its 'ToOutFields' instance. A singleton event gets only+-- the @wire\<Short\>@ binding, because its field tuple is @()@.+deriveWireCtors ::+  -- | event sum type, e.g. @\'\'UserEvent@+  Name ->+  -- | pairs of (constructor name, short name)+  [(String, String)] ->+  Q [Dec]+deriveWireCtors evtName specs = do+  ctors <- reifyCtors evtName "deriveWireCtors"+  let ctorMap = [(nameBase n, c) | c <- ctors, n <- conNames c]+  genWireCtors evtName ctorMap specs++-- | Like 'deriveWireCtors', but enumerate every constructor of the event+-- sum type automatically, using each constructor's own name as its+-- short-name suffix. Generates @wire\<Ctor\>@ (and, for record-payload+-- events, a @\<Ctor\>TermFields@ record plus its 'ToOutFields' instance)+-- for each constructor. Reach for the enumerated 'deriveWireCtors' when+-- you need an abbreviated short name that differs from the constructor+-- name.+deriveWireCtorsAll ::+  -- | event sum type, e.g. @\'\'OrderEvent@+  Name ->+  Q [Dec]+deriveWireCtorsAll evtName = do+  ctors <- reifyCtors evtName "deriveWireCtorsAll"+  let ctorMap = [(nameBase n, c) | c <- ctors, n <- conNames c]+      specs = [(nameBase n, nameBase n) | c <- ctors, n <- conNames c]+  genWireCtors evtName ctorMap specs++-- | Options for 'deriveWireCtorsWith'. Same semantics as+-- 'DeriveCtorOptions' but for the event side: 'suffixOverridesW' maps an+-- event constructor name to its short-name suffix (used for @wire<Short>@+-- and, for record-payload events, the @<Short>TermFields@ record);+-- 'excludeCtorsW' names event constructors to skip.+data DeriveWireOptions = DeriveWireOptions+  { suffixOverridesW :: Map String String,+    excludeCtorsW :: Set String+  }++-- | Default event options: no overrides, no exclusions. With this,+-- behaviour is identical to 'deriveWireCtorsAll'.+defaultDeriveWireOptions :: DeriveWireOptions+defaultDeriveWireOptions =+  DeriveWireOptions+    { suffixOverridesW = Map.empty,+      excludeCtorsW = Set.empty+    }++-- | Derive event-constructor helpers for every constructor of the event+-- sum type, like 'deriveWireCtorsAll', but honouring per-constructor+-- short-name overrides and an exclude set carried in 'DeriveWireOptions'.+-- A constructor in 'suffixOverridesW' uses the mapped short name;+-- otherwise it defaults to its own name; a constructor in 'excludeCtorsW'+-- is skipped entirely.+--+-- Unknown override\/exclude keys and duplicate resolved short names both+-- abort the splice at compile time with a precise message (via the same+-- 'resolveCtorSpecs' machinery the command side uses). For a constructor+-- present in 'suffixOverridesW', the generated declarations are+-- byte-for-byte identical to what 'deriveWireCtors' produces for the same+-- @(constructor, short)@ pair.+deriveWireCtorsWith ::+  -- | event sum type, e.g. @\'\'OverEvent@+  Name ->+  DeriveWireOptions ->+  Q [Dec]+deriveWireCtorsWith evtName opts = do+  ctors <- reifyCtors evtName "deriveWireCtorsWith"+  let ctorMap = [(nameBase n, c) | c <- ctors, n <- conNames c]+      allCtors = map fst ctorMap+  specs <-+    resolveCtorSpecs+      "deriveWireCtorsWith"+      allCtors+      (suffixOverridesW opts)+      (excludeCtorsW opts)+  genWireCtors evtName ctorMap specs++-- | Fuse 'deriveAggregateCtorsAll' and 'deriveWireCtorsAll' into one+-- splice covering an aggregate's command and event constructors. Given+-- the command sum type, its register-file slot list, and the event sum+-- type, this emits every declaration both @*All@ variants would, using+-- each constructor's own name as its short-name suffix.+--+-- @++-- $('deriveAggregate' \'\'OrderCmd \'\'OrderCartRegs \'\'OrderEvent)+-- @++deriveAggregate ::+  -- | command sum type, e.g. @\'\'OrderCmd@+  Name ->+  -- | register-file slot list, e.g. @\'\'OrderCartRegs@+  Name ->+  -- | event sum type, e.g. @\'\'OrderEvent@+  Name ->+  Q [Dec]+deriveAggregate cmdName regsName evtName = do+  cmdDecs <- deriveAggregateCtorsAll cmdName regsName+  evtDecs <- deriveWireCtorsAll evtName+  pure (cmdDecs ++ evtDecs)++-- | Generate the per-aggregate B-presentation view: a singletons GADT+-- (one constructor per vertex, indexed by the promoted vertex type),+-- a per-vertex View GADT (one constructor per vertex carrying the+-- live slots as record fields), and the projection function+-- @viewFor :: SVertex v -> RegFile rs -> View v@.+--+-- See @docs/research/genview-th-splice-design.md@ for the full+-- design — splice signature, spec format, validation rules, and+-- worked expansion against 'Jitsurei.UserRegistration'.+--+-- == Worked invocation+--+-- @++-- $('deriveView' \'\'Vertex \'\'UserRegRegs+--     "SUserVertex" "UserView" "userView"+--     [ ("PotentialCustomer",    [])+--     , ("Registering",          [])+--     , ("RequiresConfirmation", ["email", "confirmCode"])+--     , ("Confirmed",            ["email", "confirmedAt"])+--     , ("Deleted",              ["email", "deletedAt"])+--     ])+-- @++deriveView ::+  -- | vertex enum, e.g. @\'\'Vertex@+  Name ->+  -- | register-file slot list, e.g. @\'\'UserRegRegs@+  Name ->+  -- | name of the singletons GADT to generate,+  --     e.g. @"SUserVertex"@+  String ->+  -- | name of the View GADT, e.g. @"UserView"@+  String ->+  -- | name of the projection function,+  --     e.g. @"userView"@+  String ->+  -- | per-vertex spec: pairs of+  --     (vertex constructor name,+  --     list of slot names live in that vertex)+  [(String, [String])] ->+  Q [Dec]+deriveView+  vertexName+  regsName+  sVertexNameStr+  viewNameStr+  viewFunNameStr+  spec = do+    -- Phase 1: reify the vertex enum.+    ctors <- reifyCtors vertexName "deriveView"+    let vertexCtorNames = concatMap conNames ctors+        vertexCtorByBase =+          [(nameBase n, n) | n <- vertexCtorNames]+    -- Phase 2: reify the slot list.+    slotPairs <- reifySlotList regsName+    let slotNamesInRegs = map fst slotPairs+    -- Phase 3: validate (five checks).+    validateSpecCoverage vertexName vertexCtorNames spec+    validateSpecSlots regsName slotNamesInRegs spec+    validatePrefixUniqueness spec+    -- Phase 4: code-gen.+    let sVertexN = mkName sVertexNameStr+        viewN = mkName viewNameStr+        viewFunN = mkName viewFunNameStr+        vIdx = mkName "v"+        vertexCtor name = case lookup name vertexCtorByBase of+          Just n -> n+          Nothing ->+            error $+              "deriveView: bug — validated vertex "+                <> show name+                <> " missing from reified ctor list"+        slotType slotName = case lookup slotName slotPairs of+          Just t -> t+          Nothing ->+            error $+              "deriveView: bug — validated slot "+                <> show slotName+                <> " missing from reified slot list"++    -- (a) Singletons GADT.+    let sCtors =+          [ GadtC+              [mkName ("S" <> vName)]+              []+              (AppT (ConT sVertexN) (PromotedT (vertexCtor vName)))+          | (vName, _) <- spec+          ]+        sDataDec =+          DataD+            []+            sVertexN+            [KindedTV vIdx BndrReq (ConT vertexName)]+            Nothing+            sCtors+            []+        sShowDec =+          StandaloneDerivD+            Nothing+            []+            ( AppT+                (ConT ''Show)+                (AppT (ConT sVertexN) (VarT vIdx))+            )+        sEqDec =+          StandaloneDerivD+            Nothing+            []+            ( AppT+                (ConT ''Eq)+                (AppT (ConT sVertexN) (VarT vIdx))+            )++    -- (b) View GADT.+    let lazyBang = Bang NoSourceUnpackedness NoSourceStrictness+        mkViewCtor (vName, slots) =+          let viewCtorN = mkName (vName <> "V")+              resultT = AppT (ConT viewN) (PromotedT (vertexCtor vName))+              prefix = vertexFieldPrefix vName+           in case slots of+                [] -> GadtC [viewCtorN] [] resultT+                _ ->+                  RecGadtC+                    [viewCtorN]+                    [ ( mkName (vertexFieldName prefix s),+                        lazyBang,+                        slotType s+                      )+                    | s <- slots+                    ]+                    resultT+        viewCtors = map mkViewCtor spec+        viewDataDec =+          DataD+            []+            viewN+            [KindedTV vIdx BndrReq (ConT vertexName)]+            Nothing+            viewCtors+            []+        viewShowDec =+          StandaloneDerivD+            Nothing+            []+            ( AppT+                (ConT ''Show)+                (AppT (ConT viewN) (VarT vIdx))+            )+        viewEqDec =+          StandaloneDerivD+            Nothing+            []+            ( AppT+                (ConT ''Eq)+                (AppT (ConT viewN) (VarT vIdx))+            )++    -- (c) Projection function.+    let regsTy = AppT (ConT ''RegFile) (ConT regsName)+        funTy =+          ForallT+            [PlainTV vIdx SpecifiedSpec]+            []+            ( arrows+                [ AppT (ConT sVertexN) (VarT vIdx),+                  regsTy,+                  AppT (ConT viewN) (VarT vIdx)+                ]+            )+        viewFunSig = SigD viewFunN funTy+    regsVar <- newName "regs"+    let mkClause (vName, slots) =+          let sCtorN = mkName ("S" <> vName)+              viewCtorN = mkName (vName <> "V")+              (regsPat, body) = case slots of+                [] -> (WildP, ConE viewCtorN)+                _ ->+                  let reads_ =+                        [ AppE+                            ( AppE+                                (VarE '(!))+                                (VarE regsVar)+                            )+                            (LabelE s)+                        | s <- slots+                        ]+                   in (VarP regsVar, foldl AppE (ConE viewCtorN) reads_)+           in Clause [ConP sCtorN [] [], regsPat] (NormalB body) []+        viewFunDef = FunD viewFunN (map mkClause spec)++    pure+      [ sDataDec,+        sShowDec,+        sEqDec,+        viewDataDec,+        viewShowDec,+        viewEqDec,+        viewFunSig,+        viewFunDef+      ]+    where+      arrows :: [Type] -> Type+      arrows [] = error "deriveView: arrows on empty list"+      arrows [t] = t+      arrows (t : ts) = AppT (AppT ArrowT t) (arrows ts)++-- | Field name from a vertex prefix and a slot name:+-- @\"<prefix><Slot>\"@ where the slot name's first letter is+-- upper-cased.+vertexFieldName :: String -> String -> String+vertexFieldName prefix slotName = case slotName of+  [] -> prefix+  (c : cs) -> prefix <> (toUpper c : cs)++-- * Internal helpers -----------------------------------------------------++reifyCtors :: Name -> String -> Q [Con]+reifyCtors n caller = do+  info <- reify n+  case info of+    TyConI (DataD _ _ _ _ ctors _) -> pure ctors+    _ ->+      fail $+        caller+          <> ": expected a data declaration for "+          <> show n+          <> ", got "+          <> show info++conNames :: Con -> [Name]+conNames (NormalC n _) = [n]+conNames (RecC n _) = [n]+conNames (InfixC _ n _) = [n]+conNames _ = []++-- | Three-state classification of a constructor's payload.+--+--   * @Just Nothing@  — singleton (zero-arg 'NormalC').+--   * @Just (Just t)@ — single-arg 'NormalC' with payload type @t@.+--   * @Nothing@       — record-syntax or multi-arg ctor (unsupported).+conPayload :: Con -> Maybe (Maybe Type)+conPayload (NormalC _ []) = Just Nothing+conPayload (NormalC _ [(_, t)]) = Just (Just t)+conPayload _ = Nothing++-- | Shared command-side codegen: given the reified constructor map and a+-- resolved @(constructorName, shortName)@ spec list, emit the helper+-- declarations. All command-side entry points route through this so the+-- generated output is identical for identical resolved specs.+genAggregateCtors ::+  Name -> Name -> [(String, Con)] -> [(String, String)] -> Q [Dec]+genAggregateCtors cmdName regsName ctorMap specs =+  fmap concat . mapM (genCtor cmdName regsName ctorMap) $ specs++-- | Resolve options against the reified constructor base-names into a+-- @(constructorName, shortName)@ spec list, validating override\/exclude+-- keys and rejecting duplicate resolved short names. @caller@ is the+-- splice name used in error messages. Sum-type-agnostic so both the+-- command side ('deriveAggregateCtorsWith') and the event side+-- ('deriveWireCtorsWith') reuse it.+resolveCtorSpecs ::+  -- | caller name, e.g. "deriveAggregateCtorsWith"+  String ->+  -- | all constructor base-names of the sum type+  [String] ->+  -- | suffix overrides (constructor -> short)+  Map String String ->+  -- | constructors to exclude+  Set String ->+  Q [(String, String)]+resolveCtorSpecs caller allCtors overrides excludes = do+  -- (a) every override/exclude key must be a real constructor.+  let known = Set.fromList allCtors+      overKeys = Map.keysSet overrides+      badKeys =+        Set.toList+          ( (overKeys `Set.union` excludes)+              `Set.difference` known+          )+  case badKeys of+    [] -> pure ()+    _ ->+      fail $+        caller+          <> ": option(s) name "+          <> showList' badKeys+          <> " which are not constructors of this type; "+          <> "valid constructors: "+          <> showList' allCtors+  -- (b) build the resolved spec, dropping excluded constructors and+  -- applying overrides (default short name = constructor name).+  let kept = [c | c <- allCtors, not (c `Set.member` excludes)]+      specs = [(c, Map.findWithDefault c c overrides) | c <- kept]+  -- (c) reject duplicate resolved short names (would clash at codegen).+  let shorts = map snd specs+      dups = [s | (s : _ : _) <- group (sort shorts)]+  case dups of+    [] -> pure ()+    _ ->+      fail $+        caller+          <> ": short name(s) "+          <> showList' dups+          <> " are produced by more than one constructor; "+          <> "rename via suffixOverrides or exclude one"+  pure specs++genCtor ::+  Name ->+  Name ->+  [(String, Con)] ->+  (String, String) ->+  Q [Dec]+genCtor cmdName regsName ctorMap (ctorStr, shortStr) =+  case lookup ctorStr ctorMap of+    Nothing ->+      fail $+        "deriveAggregateCtors: ctor "+          <> show ctorStr+          <> " not found in "+          <> show cmdName+    Just con -> case conPayload con of+      Nothing ->+        fail $+          "deriveAggregateCtors: ctor "+            <> show ctorStr+            <> " has unsupported shape (multi-arg or record-syntax)"+      Just Nothing ->+        case conNames con of+          (cn : _) -> singletonDecls cmdName regsName ctorStr shortStr cn+          [] ->+            fail $+              "deriveAggregateCtors: could not extract "+                <> "ctor name for "+                <> show ctorStr+      Just (Just payTy) ->+        recordDecls cmdName regsName ctorStr shortStr payTy++singletonDecls ::+  Name -> Name -> String -> String -> Name -> Q [Dec]+singletonDecls cmdName regsName ctorStr shortStr ctorN = do+  let inCtorN = mkName ("inCtor" <> shortStr)+      isN = mkName ("is" <> shortStr)+  inCtorSig <-+    sigD+      inCtorN+      [t|InCtor $(conT cmdName) '[]|]+  inCtorDef <-+    funD+      inCtorN+      [ clause+          []+          ( normalB+              [|+                mkInCtor0+                  $(litE (stringL ctorStr))+                  $(conE ctorN)+                |]+          )+          []+      ]+  isSig <-+    sigD+      isN+      [t|HsPred $(conT regsName) $(conT cmdName)|]+  isDef <-+    funD+      isN+      [ clause+          []+          ( normalB+              [|matchInCtor $(varE inCtorN)|]+          )+          []+      ]+  pure [inCtorSig, inCtorDef, isSig, isDef]++recordDecls ::+  Name -> Name -> String -> String -> Type -> Q [Dec]+recordDecls cmdName regsName ctorStr shortStr payTy = do+  let inCtorN = mkName ("inCtor" <> shortStr)+      inpN = mkName ("inp" <> shortStr)+      isN = mkName ("is" <> shortStr)+      slotsT = [t|RegFieldsOf $(pure payTy)|]+  r <- newName "r"+  inCtorSig <-+    sigD+      inCtorN+      [t|InCtor $(conT cmdName) $slotsT|]+  inCtorDef <-+    funD+      inCtorN+      [ clause+          []+          ( normalB+              ( appTypeE+                  [|mkInCtorVia|]+                  (litT (strTyLit ctorStr))+              )+          )+          []+      ]+  inpSig <-+    sigD+      inpN+      [t|+        Index $slotsT $(varT r) ->+        Term $(conT regsName) $(conT cmdName) $slotsT $(varT r)+        |]+  inpDef <-+    funD+      inpN+      [ clause+          []+          ( normalB+              [|TInpCtorField $(varE inCtorN)|]+          )+          []+      ]+  isSig <-+    sigD+      isN+      [t|HsPred $(conT regsName) $(conT cmdName)|]+  isDef <-+    funD+      isN+      [ clause+          []+          ( normalB+              [|matchInCtor $(varE inCtorN)|]+          )+          []+      ]+  pure [inCtorSig, inCtorDef, inpSig, inpDef, isSig, isDef]++-- | Shared event-side codegen: given the reified constructor map and a+-- resolved @(constructorName, shortName)@ spec list, emit the wire+-- declarations. All event-side entry points route through this so the+-- generated output is identical for identical resolved specs.+genWireCtors :: Name -> [(String, Con)] -> [(String, String)] -> Q [Dec]+genWireCtors evtName ctorMap specs =+  fmap concat . mapM (genWire evtName ctorMap) $ specs++genWire ::+  Name ->+  [(String, Con)] ->+  (String, String) ->+  Q [Dec]+genWire evtName ctorMap (ctorStr, shortStr) =+  case lookup ctorStr ctorMap of+    Nothing ->+      fail $+        "deriveWireCtors: ctor "+          <> show ctorStr+          <> " not found in "+          <> show evtName+    Just con -> case conPayload con of+      Just (Just payTy) -> do+        let wireN = mkName ("wire" <> shortStr)+        wireSig <-+          sigD+            wireN+            [t|+              WireCtor+                $(conT evtName)+                (FieldsOf $(pure payTy))+              |]+        wireDef <-+          funD+            wireN+            [ clause+                []+                ( normalB+                    ( appTypeE+                        [|mkWireCtorVia|]+                        (litT (strTyLit ctorStr))+                    )+                )+                []+            ]+        termRecDecs <- genTermFieldsRecord shortStr payTy+        pure ([wireSig, wireDef] ++ termRecDecs)+      Just Nothing ->+        -- Zero-arg (singleton) event: emit only the wire<Short> binding+        -- via mkWireCtor0 (no payload, so no <Short>TermFields record).+        -- Mirrors the command side's singletonDecls/mkInCtor0.+        case conNames con of+          (cn : _) -> do+            let wireN = mkName ("wire" <> shortStr)+            wireSig <-+              sigD+                wireN+                [t|WireCtor $(conT evtName) ()|]+            wireDef <-+              funD+                wireN+                [ clause+                    []+                    ( normalB+                        [|+                          mkWireCtor0+                            $(litE (stringL ctorStr))+                            $(conE cn)+                          |]+                    )+                    []+                ]+            pure [wireSig, wireDef]+          [] ->+            fail $+              "deriveWireCtors: could not extract ctor name for "+                <> show ctorStr+      Nothing ->+        fail $+          "deriveWireCtors: ctor "+            <> show ctorStr+            <> " has unsupported payload shape "+            <> "(multi-arg or record-syntax)"++-- | Per-event field-keyed record for 'B.emit' (EP-21 M4).+--+-- For each event ctor with a record payload @<Pay>@ whose fields are+-- @f1 :: T1@, @f2 :: T2@, ..., @fn :: Tn@, this emits two decls:+--+-- > data <Short>TermFields rs ci = <Short>TermFields+-- >   { f1 :: Term rs ci T1+-- >   , f2 :: Term rs ci T2+-- >   , ...+-- >   }+--+-- > instance ToOutFields (<Short>TermFields rs ci) rs ci+-- >                      (FieldsOf <Pay>) where+-- >   toOutFields <Short>TermFields { f1 = v1, f2 = v2, ... } =+-- >     OFCons v1 (OFCons v2 ... OFNil)+--+-- Field-name disambiguation across multiple events with shared+-- field names is handled by 'DuplicateRecordFields' (already on at+-- the project level); the record pattern in the instance body+-- pins the constructor explicitly so the field lookup is+-- unambiguous.+genTermFieldsRecord :: String -> Type -> Q [Dec]+genTermFieldsRecord shortStr payTy = do+  payName <- typeConstructorName payTy+  payInfo <- reify payName+  fields <- case payInfo of+    TyConI (DataD _ _ _ _ [RecC _ fs] _) -> pure fs+    TyConI (NewtypeD _ _ _ _ (RecC _ fs) _) -> pure fs+    _ ->+      fail $+        "deriveWireCtors: TermFields generation requires "+          <> "a single record-syntax constructor on payload "+          <> show payName+          <> ", got "+          <> show payInfo+  let recName = mkName (shortStr <> "TermFields")+  rsN <- newName "rs"+  ciN <- newName "ci"+  ifsN <- newName "ifs"+  let lazyBang = Bang NoSourceUnpackedness NoSourceStrictness+      -- EP-53: 'Term' is indexed by the input field schema @ifs@, so the+      -- generated record carries an @ifs@ parameter shared by every+      -- field 'Term'. 'pack' / 'emit' ties it to the 'OPack''s 'InCtor'.+      mkField (selN, _, ty) =+        ( mkName (nameBase selN),+          lazyBang,+          ConT ''Term `AppT` VarT rsN `AppT` VarT ciN `AppT` VarT ifsN `AppT` ty+        )+      recCtor = RecC recName (map mkField fields)+      recDataDec =+        DataD+          []+          recName+          [ PlainTV rsN BndrReq,+            PlainTV ciN BndrReq,+            PlainTV ifsN BndrReq+          ]+          Nothing+          [recCtor]+          []+      recTy = ConT recName `AppT` VarT rsN `AppT` VarT ciN `AppT` VarT ifsN+      -- The 'OutFields' type's @fs@ parameter is the same nested-+      -- pair tuple @FieldsOf <Pay>@ reduces to. Compute it+      -- explicitly so the instance head does not carry a type-+      -- family application (which GHC rejects in instance heads).+      fsTy = mkNestedPairTuple [ty | (_, _, ty) <- fields]+      instHead =+        ConT ''ToOutFields+          `AppT` recTy+          `AppT` VarT rsN+          `AppT` VarT ciN+          `AppT` VarT ifsN+          `AppT` fsTy+  vars <- mapM (\(selN, _, _) -> newName ("v_" <> nameBase selN)) fields+  let recPat =+        RecP+          recName+          [ (mkName (nameBase fn), VarP vn)+          | ((fn, _, _), vn) <- zip fields vars+          ]+      buildBody [] = ConE 'OFNil+      buildBody (v : vs) = ConE 'OFCons `AppE` VarE v `AppE` buildBody vs+      methodDef =+        FunD+          'toOutFields+          [Clause [recPat] (NormalB (buildBody vars)) []]+      instDec = InstanceD Nothing [] instHead [methodDef]+  pure [recDataDec, instDec]++-- | Extract a type's head constructor name. Accepts @ConT@ and the+-- common forms it might wear after kind-elaboration; rejects+-- function/forall/promoted shapes.+typeConstructorName :: Type -> Q Name+typeConstructorName (ConT n) = pure n+typeConstructorName (SigT t _) = typeConstructorName t+typeConstructorName other =+  fail $+    "deriveWireCtors: payload type must be a type constructor, "+      <> "got "+      <> show other++-- | Build the nested-pair tuple type @(t1, (t2, ..., (tn, ())))@+-- from a list of element types. This is the same shape that+-- 'Keiki.Generics.FieldsOf' reduces a record's 'Rep' to, computed+-- explicitly here so instance heads that mention the shape avoid+-- the type-family application GHC rejects.+mkNestedPairTuple :: [Type] -> Type+mkNestedPairTuple [] = TupleT 0+mkNestedPairTuple (t : ts) = AppT (AppT (TupleT 2) t) (mkNestedPairTuple ts)++-- * deriveView internals -------------------------------------------------++-- | Walk a type-synonym whose right-hand side is a promoted @[Slot]@+-- list, extracting the @(slotName, slotType)@ pairs. The walk+-- pattern-matches @PromotedConsT@ \/ @PromotedNilT@ at the list level+-- and @PromotedTupleT 2@ over @LitT (StrTyLit name)@ + slot type at+-- each cell.+reifySlotList :: Name -> Q [(String, Type)]+reifySlotList n = do+  info <- reify n+  case info of+    TyConI (TySynD _ _ rhs) -> walkList rhs+    _ ->+      fail $+        "deriveView: expected a type synonym for "+          <> show n+          <> " whose right-hand side is a promoted "+          <> "[Slot] list, got "+          <> show info+  where+    walkList :: Type -> Q [(String, Type)]+    walkList (SigT t _) = walkList t+    walkList PromotedNilT = pure []+    walkList (AppT (AppT PromotedConsT headPair) tailList) = do+      pair <- walkPair headPair+      rest <- walkList tailList+      pure (pair : rest)+    walkList other =+      fail $+        "deriveView: expected a promoted-list type at "+          <> show n+          <> ", got "+          <> show other++    walkPair :: Type -> Q (String, Type)+    walkPair (SigT t _) = walkPair t+    walkPair (AppT (AppT (PromotedTupleT 2) (LitT (StrTyLit name))) ty) =+      pure (name, ty)+    walkPair other =+      fail $+        "deriveView: expected a promoted (Symbol, Type) pair "+          <> "in slot list of "+          <> show n+          <> ", got "+          <> show other++-- | Validate that the spec lists every vertex constructor exactly+-- once. Missing, extra, and duplicate spec entries each produce a+-- precise message naming the offenders.+validateSpecCoverage ::+  Name -> [Name] -> [(String, [String])] -> Q ()+validateSpecCoverage vertexName vertexCtorNames spec = do+  let vertexNames = map nameBase vertexCtorNames+      specNames = map fst spec+      duplicates = [n | (n : _ : _) <- group (sort specNames)]+      missing = vertexNames \\ specNames+      extras = specNames \\ vertexNames+  case duplicates of+    [] -> pure ()+    _ ->+      fail $+        "deriveView: spec lists vertex(es) "+          <> showList' duplicates+          <> " more than once"+  case missing of+    [] -> pure ()+    _ ->+      fail $+        "deriveView: spec is missing constructors of "+          <> show vertexName+          <> ": "+          <> showList' missing+  case extras of+    [] -> pure ()+    _ ->+      fail $+        "deriveView: spec names constructors not in "+          <> show vertexName+          <> ": "+          <> showList' extras++-- | Validate that every named slot exists in the register-file slot+-- list, and that no spec entry names the same slot twice.+validateSpecSlots ::+  Name -> [String] -> [(String, [String])] -> Q ()+validateSpecSlots regsName slotNamesInRegs spec =+  mapM_ checkOne spec+  where+    checkOne (vertexCtorName, slots) = do+      let dupSlots = [s | (s : _ : _) <- group (sort slots)]+      case dupSlots of+        [] -> pure ()+        _ ->+          fail $+            "deriveView: spec entry "+              <> show vertexCtorName+              <> " lists slot(s) "+              <> showList' dupSlots+              <> " more than once"+      let missing = slots \\ slotNamesInRegs+      case missing of+        [] -> pure ()+        _ ->+          fail $+            "deriveView: spec entry "+              <> show vertexCtorName+              <> " names slot(s) "+              <> showList' missing+              <> " which are not slots of "+              <> show regsName+              <> "; known slots: "+              <> showList' slotNamesInRegs++-- | Validate that the per-vertex field-name prefixes+-- (@filter isUpper >>> map toLower@) are pairwise distinct so the+-- generated View GADT has no field-name collisions across+-- constructors.+validatePrefixUniqueness :: [(String, [String])] -> Q ()+validatePrefixUniqueness spec =+  case collisions of+    [] -> pure ()+    ((pref, ns) : _) ->+      fail $+        "deriveView: vertices "+          <> showList' ns+          <> " produce the same field-name prefix "+          <> show pref+          <> "; rename one"+  where+    prefixed = [(vertexFieldPrefix n, n) | (n, _) <- spec]+    collisions =+      [ (pref, [n | (p', n) <- prefixed, p' == pref])+      | pref <- nub (map fst prefixed),+        length [() | (p', _) <- prefixed, p' == pref] > 1+      ]++-- | Field-name prefix for a vertex name: lower-cased concatenation+-- of the vertex name's upper-case letters. Examples:+-- @\"PotentialCustomer\" -> \"pc\"@,+-- @\"RequiresConfirmation\" -> \"rc\"@,+-- @\"Confirmed\" -> \"c\"@,+-- @\"Deleted\" -> \"d\"@.+vertexFieldPrefix :: String -> String+vertexFieldPrefix = map toLower . filter isUpper++-- | Show a list of strings in @{ "a", "b", "c" }@ form for error+-- messages.+showList' :: [String] -> String+showList' [] = "{}"+showList' [x] = "{ " <> show x <> " }"+showList' (x : xs) = "{ " <> show x <> concatMap (\y -> ", " <> show y) xs <> " }"
+ src/Keiki/Internal/Slots.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE TypeFamilies #-}++-- | Type-level slot-name machinery used by the @(w :: [Symbol])@ index+-- on 'Keiki.Core.Update' (EP-18 of MasterPlan 6).+--+-- The keiki invariant is that slot names within a register file are+-- pairwise distinct. EP-18 promotes that invariant from a runtime+-- check (the old @combine@'s integer-position overlap test) to a+-- type-level constraint by:+--+--   * indexing 'Keiki.Core.Update' over @(w :: [Symbol])@, the set of+--     slot names the update writes; and+--   * requiring 'Disjoint' @w1@ @w2@ on the smart constructor that+--     combines two updates.+--+-- This module owns the type-family / GADT machinery the index uses;+-- 'Keiki.Core' and 'Keiki.Composition' import it. The 'IndexN' GADT+-- below is a slot-name-tagged variant of 'Keiki.Core.Index' so the+-- 'USet' constructor can recover its written slot's symbol at the+-- type level.+module Keiki.Internal.Slots+  ( -- * Type-level lists+    Concat,+    Member,+    Disjoint,++    -- * Slot-name projection+    Names,++    -- * Slot-name-tagged register index+    IndexN (..),+    HasIndexN (..),+    indexNToInt,+    indexNName,+  )+where++import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy (..))+import GHC.OverloadedLabels (IsLabel (..))+import GHC.TypeError (ErrorMessage (..), TypeError)+import GHC.TypeLits (CmpSymbol, KnownSymbol, Symbol, symbolVal)++-- | Type-level list concatenation on @[Symbol]@.+type family Concat (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where+  Concat '[] ys = ys+  Concat (x ': xs) ys = x ': Concat xs ys++-- | Type-level membership: @True@ iff @x@ appears in @ys@. Decided by+-- 'CmpSymbol' (compile-time symbol comparison).+type family Member (x :: Symbol) (ys :: [Symbol]) :: Bool where+  Member _ '[] = 'False+  Member x (y ': ys) = MemberCmp (CmpSymbol x y) x ys++type family MemberCmp (cmp :: Ordering) (x :: Symbol) (ys :: [Symbol]) :: Bool where+  MemberCmp 'EQ _ _ = 'True+  MemberCmp _ x ys = Member x ys++-- | Disjointness of two slot-name sets. A 'Constraint' that fires a+-- 'TypeError' naming the duplicated symbol when an overlap is detected.+type family Disjoint (xs :: [Symbol]) (ys :: [Symbol]) :: Constraint where+  Disjoint '[] _ = ()+  Disjoint (x ': xs) ys = (NotMember x ys, Disjoint xs ys)++-- | Per-element disjointness witness used by 'Disjoint'. Walks @ys@,+-- raising 'TypeError' when @x@ collides with an element.+type family NotMember (x :: Symbol) (ys :: [Symbol]) :: Constraint where+  NotMember _ '[] = ()+  NotMember x (y ': ys) = (NotMemberCmp (CmpSymbol x y) x y, NotMember x ys)++type family NotMemberCmp (cmp :: Ordering) (x :: Symbol) (y :: Symbol) :: Constraint where+  NotMemberCmp 'LT _ _ = ()+  NotMemberCmp 'GT _ _ = ()+  NotMemberCmp 'EQ x _ =+    TypeError+      ( 'Text "Keiki.Internal.Slots.Disjoint: slot \""+          ':<>: 'Text x+          ':<>: 'Text "\" is written by both halves of `combine`. "+          ':$$: 'Text "Each register slot may be written at most once per edge update."+      )++-- | Project the slot-name list out of a slot list. The kind+-- @[(Symbol, Type)]@ is keiki's @[Slot]@ at the kind level (a synonym+-- defined in 'Keiki.Core'); written here in unfolded form to avoid a+-- circular import.+type family Names (rs :: [(Symbol, Type)]) :: [Symbol] where+  Names '[] = '[]+  Names ('(s, _r) ': rest) = s ': Names rest++-- | A slot-name-tagged register index. Where 'Keiki.Core.Index'+-- existentially hides the slot symbol it points at, 'IndexN' carries+-- it as a phantom @s@. Used by 'Keiki.Core.USet' so the 'Update''s+-- written-slot index can be derived mechanically.+data IndexN (s :: Symbol) (rs :: [(Symbol, Type)]) (r :: Type) where+  IZ :: (KnownSymbol s) => IndexN s ('(s, r) ': rs) r+  IS :: IndexN s rs r -> IndexN s ('(s', r') ': rs) r++-- | Resolve a label @s@ against a slot list @rs@ to an 'IndexN' for+-- the value at that slot. The functional dependency @s rs -> r@+-- ensures that a label uniquely determines the slot's type.+class+  HasIndexN (s :: Symbol) (rs :: [(Symbol, Type)]) (r :: Type)+    | s rs -> r+  where+  indexN :: IndexN s rs r++instance+  {-# OVERLAPPING #-}+  (KnownSymbol s) =>+  HasIndexN s ('(s, r) ': rs) r+  where+  indexN = IZ++instance+  {-# OVERLAPPABLE #-}+  forall s s' r r' rs.+  (HasIndexN s rs r) =>+  HasIndexN s ('(s', r') ': rs) r+  where+  indexN = IS (indexN @s @rs @r)++-- | Slot-name-tagged label resolution. Lets aggregate authors write+-- @USet (#email :: IndexN "email" UserRegRegs Email) ...@ (or just+-- @USet #email ...@ when GHC can infer the type) and pick up the+-- @s@ phantom that 'Keiki.Core.USet' demands.+instance+  forall s rs r.+  (HasIndexN s rs r) =>+  IsLabel s (IndexN s rs r)+  where+  fromLabel = indexN @s @rs @r++-- | The integer position of an 'IndexN' in its slot list.+indexNToInt :: IndexN s rs r -> Int+indexNToInt IZ = 0+indexNToInt (IS i) = 1 + indexNToInt i++-- | The slot name carried by an 'IndexN'. Recovered from the+-- 'KnownSymbol' constraint at 'IZ'; recurses through 'IS'.+indexNName :: forall s rs r. (KnownSymbol s) => IndexN s rs r -> String+indexNName _ = symbolVal (Proxy @s)
+ src/Keiki/NoThunks.hs view
@@ -0,0 +1,42 @@+-- The 'NoThunks' instances for 'RegFile' are deliberate orphans: the+-- type lives in "Keiki.Core" (which stays free of observability deps)+-- and the class lives in @nothunks@. See the Decision Log of+-- @docs/plans/23-nothunks-instances-for-regfile-and-symtransducer-state.md@.+{-# OPTIONS_GHC -Wno-orphans #-}++-- | 'NoThunks' instances for keiki state types.+--+-- Long-running embedders that keep aggregate state in memory across+-- many @step@ calls can wrap each step's resulting state in+-- @noThunks ["regfile", "vertex"] (s, regs)@ to detect leaked thunks+-- before they accumulate.+--+-- Scope is intentionally narrow: data-bearing state types only+-- ('RegFile', 'Composite'). Function-bearing types ('Edge',+-- 'SymTransducer', 'HsPred', 'Term', 'OutTerm', 'Update') are excluded+-- — 'NoThunks' cannot meaningfully inspect Haskell closures, so+-- instances would be vacuous.+--+-- The 'RegFile' instance recurses on the slot spine. The @r@ field on+-- 'RCons' is lazy by construction (see 'Keiki.Core.RegFile'); this+-- instance is the canonical way to detect a thunk that has accumulated+-- in a slot value across repeated 'Keiki.Core.runUpdate' calls.+module Keiki.NoThunks () where++import Keiki.Core (RegFile (..))+import NoThunks.Class (NoThunks (..), allNoThunks)++instance NoThunks (RegFile '[]) where+  showTypeOf _ = "RegFile '[]"+  wNoThunks _ RNil = pure Nothing++instance+  (NoThunks r, NoThunks (RegFile rs)) =>+  NoThunks (RegFile ('(s, r) ': rs))+  where+  showTypeOf _ = "RegFile (s ': rs)"+  wNoThunks ctx (RCons _proxy r rest) =+    allNoThunks+      [ noThunks ("RCons.value" : ctx) r,+        noThunks ("RCons.tail" : ctx) rest+      ]
+ src/Keiki/Operators.hs view
@@ -0,0 +1,69 @@+-- | Re-exports of keiki's predicate and term operators, intended to be+-- imported __qualified__ so they cannot clash with the operators that+-- the @lens@ / @generic-lens@ libraries (or a service prelude that+-- re-exports them) bring into scope unqualified.+--+-- The sharpest clash is @(.>)@: in @lens@ it is optic composition, in+-- keiki it is the greater-than comparison that builds an 'HsPred'. With+--+-- @+-- import qualified Keiki.Operators as K+-- @+--+-- you write @x K..\> y@ for the keiki comparison and leave the bare+-- @(.>)@ to @lens@ — no @hiding@ clause required.+--+-- This module adds nothing new: every export here is defined in and+-- re-exported from "Keiki.Core". See @docs\/guide\/generic-lens-and-label-reads.md@+-- for the full import recipe and the @B.requireGt@-vs-@(.>)@ guidance.+module Keiki.Operators+  ( -- * Comparison (build an 'Keiki.Core.HsPred')+    (.<),+    (.<=),+    (.>),+    (.>=),+    (.==),+    (./=),++    -- * Logical+    (.&&),+    (.||),+    pnot,++    -- * Structural arithmetic on 'Keiki.Core.Term's+    (.+),+    (.-),+    (.*),++    -- * Function-style arithmetic aliases (clash-free already)+    tadd,+    tsub,+    tmul,+  )+where++import Keiki.Core+  ( pnot,+    tadd,+    tmul,+    tsub,+    (.&&),+    (.*),+    (.+),+    (.-),+    (./=),+    (.<),+    (.<=),+    (.==),+    (.>),+    (.>=),+    (.||),+  )++-- Note: no fixity declarations are restated here. On GHC 9.12 / GHC2024 a+-- fixity signature requires an accompanying binding in the same module+-- (GHC-44432: "lacks an accompanying binding"), and these names are merely+-- re-exported, not bound here. That is harmless: a re-exported operator+-- carries the fixity from its defining module, so a qualified user of+-- @Keiki.Operators@ (e.g. @x K..> y@) gets the @infix 4@ from "Keiki.Core"+-- automatically.
+ src/Keiki/Profunctor.hs view
@@ -0,0 +1,974 @@+-- 'unsafeCoerceDisjointness' fabricates a 'Disjoint' constraint+-- dictionary via 'unsafeCoerce' on the trivially-disjoint+-- @Disjoint '[] '[]@ witness. GHC sees the @forall xs ys.@ as+-- ambiguous because neither @xs@ nor @ys@ appear in the result; that+-- is intentional — call sites pin them via 'TypeApplications'.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Existential wrapper for 'SymTransducer' enabling participation in+-- the standard 'Profunctor' / 'Category' ecosystem, plus standalone+-- variance combinators on the concrete 'SymTransducer' type.+--+-- The wrapper 'SomeSymTransducer ci co' hides the register-file slot+-- list and the control-vertex type, exposing only the input alphabet+-- @ci@ and the output alphabet @co@. This is the form ecosystem+-- typeclasses ('Profunctor', 'Category', 'Strong', 'Choice', 'Arrow')+-- expect.+--+-- See @docs/plans/27-existential-wrapper-for-symtransducer-plus-profunctor-instance-and-variance-combinators.md@+-- for the design rationale and the documented variance caveat:+-- transducers produced by 'lmapCi' / 'rmapCo' / 'dimapTransducer' /+-- 'lmapMaybeCi' do *not* preserve the round-trip guarantee of+-- 'Keiki.Core.solveOutput'. Forward processing+-- ('Keiki.Core.delta', 'Keiki.Core.omega', 'Keiki.Core.evalPred',+-- 'Keiki.Core.evalTerm') is unaffected; only the inversion-from-event+-- path is dropped on lmapped/rmapped edges. See each combinator's+-- haddock for the precise contract.+--+-- This module also hosts the 'Control.Category.Category' instance+-- on 'SomeSymTransducer' (EP-28 of MasterPlan 9). The 'Cat.id' lift+-- uses 'identityTransducer' (a one-vertex transducer that emits its+-- input as its output via a phantom one-slot register file); 'Cat..'+-- delegates to 'Keiki.Composition.compose' after a *runtime*+-- slot-name overlap check that raises 'CategoryOverlapError' on+-- collisions. The check exists because the wrapper hides @rs@, so+-- 'compose''s static @Disjoint (Names rs1) (Names rs2)@ constraint+-- cannot be discharged by GHC at the wrapper boundary.+module Keiki.Profunctor+  ( -- * Existential wrapper+    SomeSymTransducer (..),+    someSymTransducer,++    -- * Standalone variance combinators on the concrete 'SymTransducer'+    lmapCi,+    rmapCo,+    dimapTransducer,+    lmapMaybeCi,++    -- * Identity transducer (concrete form; 'Cat.id' uses the sentinel constructor)+    IdVertex (..),+    identityTransducer,++    -- * Arrow's @arr@ (concrete form; the 'Arr.Arrow' instance wraps it)+    arrTransducer,++    -- * Category-instance overlap exception+    CategoryOverlapError (..),+  )+where++import Control.Arrow qualified as Arr+import Control.Category qualified as Cat+import Control.Exception (Exception, throw)+import Data.Profunctor (Choice (..), Profunctor (..), Strong (..))+import Data.Proxy (Proxy (..))+import Keiki.Composition (WeakenR, alternative, compose)+import Keiki.Core+import Keiki.Generics (Append)+import Unsafe.Coerce (unsafeCoerce)++-- | Existential wrapper hiding @rs@ (register-file slot list) and+-- @s@ (control vertex), exposing only the input alphabet @ci@ and+-- output alphabet @co@. Predicate carrier is fixed to 'HsPred' since+-- "Keiki.Composition"'s combinators are pinned to that carrier.+--+-- The packed constraints @WeakenR rs@ and @KnownSlotNames rs@ are+-- needed by the 'Cat.Category' instance: 'compose' demands+-- @WeakenR rs1@, and the runtime slot-overlap check that guards+-- 'Cat..' reads each transducer's slot names at the value level+-- via @KnownSlotNames@. The packed constraints @Bounded s@ and+-- @Enum s@ let pattern-matched-out transducers participate in the+-- symbolic analyses ('Keiki.Symbolic.isSingleValuedSym',+-- 'Keiki.Core.checkHiddenInputs'), which both enumerate the vertex+-- type. Every keiki vertex type already derives 'Bounded' and+-- 'Enum' (see 'Keiki.Fixtures.EmailDelivery.EmailVertex',+-- 'Keiki.CompositionAlternativeSpec.PingVertex', and 'IdVertex'+-- in this module), so packing the constraints does not restrict+-- what users can wrap.+--+-- The wrapper has two constructors:+--+--   * 'SomeSymTransducer' — wraps a concrete 'SymTransducer'.+--   * 'SomeSymIdentity'   — a sentinel for 'Cat.id'. Constraint+--     @ci ~ co@ comes from the constructor's GADT signature.+--+-- The sentinel exists because 'Keiki.Composition.compose' substitutes+-- t2's 'TInpCtorField'-on-@ic2@ against t1's 'WireCtor'-named+-- emission, requiring @icName ic2 == wcName wc1@ for the substitution+-- to be sound. A *generic* identity transducer (one whose 'InCtor' is+-- the same regardless of @ci@) cannot satisfy this for arbitrary+-- upstream wire names. The sentinel sidesteps this by short-circuiting+-- @id . t@ and @t . id@ in 'Cat..' rather than running them through+-- 'compose'. See 'identityTransducer' for the concrete-identity+-- transducer that some non-Category code paths still want.+--+-- Pattern-match on the constructor to recover the underlying+-- 'SymTransducer' (the @rs@ and @s@ variables come into scope as+-- skolem types — they may not escape the pattern match). Handle+-- 'SomeSymIdentity' explicitly when traversing arbitrary+-- 'SomeSymTransducer' values.+data SomeSymTransducer ci co where+  SomeSymTransducer ::+    ( WeakenR rs,+      KnownSlotNames rs,+      Bounded s,+      Enum s+    ) =>+    SymTransducer (HsPred rs ci) rs s ci co ->+    SomeSymTransducer ci co+  SomeSymIdentity :: SomeSymTransducer a a++-- | Smart constructor: lift a concrete 'SymTransducer' into the+-- wrapper. Equivalent to applying the data constructor; provided for+-- naming consistency with the rest of @Keiki.Profunctor@'s exports+-- and for users who prefer functions over constructors.+someSymTransducer ::+  ( WeakenR rs,+    KnownSlotNames rs,+    Bounded s,+    Enum s+  ) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  SomeSymTransducer ci co+someSymTransducer = SomeSymTransducer++-- * Standalone variance combinators ---------------------------------------++-- | Pre-compose with a contramap on the input alphabet. Walks every+-- 'InCtor' inside the transducer's guards / updates / outputs and+-- replaces each with one whose 'icMatch' is precomposed with @f@.+--+-- /Variance caveat:/ the rewritten 'InCtor's 'icBuild' is poisoned+-- (raises a runtime error if invoked) — callers must not invoke+-- 'Keiki.Core.solveOutput' on edges produced by this combinator. The+-- forward evaluation path ('Keiki.Core.evalPred',+-- 'Keiki.Core.evalTerm', 'Keiki.Core.delta', 'Keiki.Core.omega') only+-- ever consults 'icMatch'; it is unaffected by the poisoned+-- 'icBuild'.+lmapCi ::+  forall ci ci' rs s co.+  (ci' -> ci) ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  SymTransducer (HsPred rs ci') rs s ci' co+lmapCi f t =+  SymTransducer+    { edgesOut = \s -> map (rewriteEdge f) (edgesOut t s),+      initial = initial t,+      initialRegs = initialRegs t,+      isFinal = isFinal t+    }++-- | Pre-compose with a partial contramap on the input alphabet.+-- Inputs for which @f@ returns 'Nothing' fail every guard's+-- structural 'PInCtor' check, effectively filtering them out of the+-- transducer's command stream.+--+-- /Variance caveat:/ same as 'lmapCi' — 'Keiki.Core.solveOutput' is+-- not preserved.+lmapMaybeCi ::+  forall ci ci' rs s co.+  (ci' -> Maybe ci) ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  SymTransducer (HsPred rs ci') rs s ci' co+lmapMaybeCi f t =+  SymTransducer+    { edgesOut = \s -> map (rewriteEdgeMaybe f) (edgesOut t s),+      initial = initial t,+      initialRegs = initialRegs t,+      isFinal = isFinal t+    }++-- | Post-compose with a covariant map on the output alphabet. Walks+-- every 'WireCtor' inside the transducer's outputs and replaces each+-- with one whose 'wcBuild' is post-composed with @g@.+--+-- /Variance caveat:/ the rewritten 'WireCtor's 'wcMatch' is set to+-- @const Nothing@ — 'Keiki.Core.solveOutput' on rewritten edges+-- returns 'Nothing'. The forward output construction (which only+-- uses 'wcBuild') is unaffected.+rmapCo ::+  forall ci co co' rs s.+  (co -> co') ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  SymTransducer (HsPred rs ci) rs s ci co'+rmapCo g t =+  SymTransducer+    { edgesOut = \s -> map (rewriteEdgeOut g) (edgesOut t s),+      initial = initial t,+      initialRegs = initialRegs t,+      isFinal = isFinal t+    }++-- | Bidirectional map on input and output alphabets. Equivalent to+-- @'rmapCo' g . 'lmapCi' f@. /Variance caveat/ as both 'lmapCi' and+-- 'rmapCo': 'Keiki.Core.solveOutput' is not preserved on the result.+dimapTransducer ::+  (ci' -> ci) ->+  (co -> co') ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  SymTransducer (HsPred rs ci') rs s ci' co'+dimapTransducer f g = rmapCo g . lmapCi f++-- * Profunctor / Functor instances on the wrapper -----------------------++-- | Standard 'Data.Profunctor.Profunctor' instance. Delegates to the+-- standalone combinators above. Inherits their /variance caveat/:+-- 'lmap' / 'rmap' / 'dimap' on the wrapper produce transducers whose+-- 'Keiki.Core.solveOutput' is no longer informative — see each+-- combinator's haddock.+--+-- The 'SomeSymIdentity' sentinel is materialised into a concrete+-- 'identityTransducer' wrap before the variance combinators run, so+-- the @ci@/@co@ rewrites apply uniformly.+instance Profunctor SomeSymTransducer where+  dimap f g (SomeSymTransducer t) =+    SomeSymTransducer (dimapTransducer f g t)+  dimap f g SomeSymIdentity =+    SomeSymTransducer (dimapTransducer f g identityTransducer)+  lmap f (SomeSymTransducer t) =+    SomeSymTransducer (lmapCi f t)+  lmap f SomeSymIdentity =+    SomeSymTransducer (lmapCi f identityTransducer)+  rmap g (SomeSymTransducer t) =+    SomeSymTransducer (rmapCo g t)+  rmap g SomeSymIdentity =+    SomeSymTransducer (rmapCo g identityTransducer)++-- | 'Functor' on the output alphabet. @'fmap' = 'rmap'@.+instance Functor (SomeSymTransducer ci) where+  fmap = rmap++-- * Identity transducer (used by 'Cat.id') ------------------------------++-- | One-vertex enum used as the control vertex of 'identityTransducer'.+-- The single nullary constructor lets the identity transducer have a+-- single edge (from 'IdVertex' back to 'IdVertex') that copies the+-- input straight through to the output.+data IdVertex = IdVertex+  deriving stock (Eq, Show, Bounded, Enum)++-- | An 'InCtor' for an arbitrary alphabet @a@. Uses a phantom+-- one-slot register file @'[ '("payload", a) ]@ to bridge the+-- alphabet through the inversion machinery: 'icMatch' wraps any @a@+-- as a singleton 'RegFile'; 'icBuild' unwraps the same. The phantom+-- slot exists only inside this 'InCtor''s wrapping types — the+-- transducer's *real* @initialRegs@ stays 'RNil', so no runtime+-- register is allocated.+identityInCtor :: forall a. InCtor a '[ '("payload", a)]+identityInCtor =+  InCtor+    { icName = "Identity",+      icMatch = \a -> Just (RCons (Proxy @"payload") a RNil),+      icBuild = \(RCons _ a RNil) -> a+    }++-- | A 'WireCtor' for an arbitrary alphabet @a@. Uses the field-tuple+-- @(a, ())@ that 'OutFields' produces for a single-element list: one+-- field of type @a@ followed by the trailing 'OFNil' encoded as+-- @()@. Forward construction unwraps the tuple to its single+-- payload; inversion via 'wcMatch' wraps an @a@ back up.+identityWireCtor :: forall a. WireCtor a (a, ())+identityWireCtor =+  WireCtor+    { wcName = "Identity",+      wcMatch = \a -> Just (a, ()),+      wcBuild = \(a, ()) -> a+    }++-- | The identity transducer for an arbitrary alphabet @a@. One vertex+-- ('IdVertex'); one edge whose guard is @'PInCtor' 'identityInCtor'@+-- (semantically equivalent to 'PTop' standalone — 'identityInCtor''s+-- 'icMatch' always returns 'Just' — but arm-discriminating when+-- lifted by 'Keiki.Composition.alternative'), writes nothing+-- (@'UKeep'@), and emits its input as the wire output. Used by+-- 'Cat.id' on 'SomeSymTransducer'.+--+-- Forward processing on input @a@ evaluates the 'OutFields' by+-- reading the @"payload"@ slot via the 'InCtor' (which round-trips+-- @a@ through the phantom register file), then 'wcBuild :: (a, ()) -> a'+-- unwraps the field tuple to produce @a@. Inversion via+-- 'Keiki.Core.solveOutput' goes the other way and is similarly+-- well-defined; the identity transducer satisfies all keiki+-- guarantees by construction.+--+-- /Why @PInCtor identityInCtor@ rather than @PTop@:/ EP-29 M1+-- discovered that the simpler @PTop@ guard fires on every input,+-- including the *wrong arm* of an 'Keiki.Composition.alternative'+-- composite. 'liftRPredAlt PTop = PTop' (the lift recurses+-- structurally and has no PInCtor to lift), so an+-- @alternative t identityTransducer@ composite at @Left _@ inputs+-- would see *both* arms' edges fire — t1's correctly, but+-- identityTransducer's incorrectly (it should be inactive on the+-- Left arm). Replacing 'PTop' with 'PInCtor identityInCtor' is+-- semantically a no-op standalone (icMatch always succeeds) but+-- becomes arm-discriminating after 'liftLPredAlt' / 'liftRPredAlt'+-- wraps the InCtor in 'leftInCtor' / 'rightInCtor' (whose+-- 'icMatch' returns 'Nothing' on the wrong arm).+identityTransducer ::+  forall a.+  SymTransducer (HsPred '[] a) '[] IdVertex a a+identityTransducer =+  SymTransducer+    { edgesOut = \IdVertex ->+        [ Edge+            { guard = PInCtor identityInCtor,+              update = UKeep,+              output = [identityOutTerm],+              target = IdVertex+            }+        ],+      initial = IdVertex,+      initialRegs = RNil,+      isFinal = const True+    }+  where+    identityOutTerm :: OutTerm '[] a a+    identityOutTerm =+      OPack+        identityInCtor+        identityWireCtor+        (OFCons (TInpCtorField identityInCtor ZIdx) OFNil)++-- * Disjointness escape hatch (private) ---------------------------------++-- | Exception raised when 'Cat..' is invoked on two+-- 'SomeSymTransducer' values whose underlying register files share a+-- slot name. Carries the colliding slot names so the message points+-- at the actual offender.+--+-- Catch with @Control.Exception.catch@ or use @evaluate@ to force+-- the throw at a controlled point in your program.+data CategoryOverlapError = CategoryOverlapError+  { coeSlots :: [String]+  }+  deriving stock (Eq, Show)++instance Exception CategoryOverlapError++-- | A constraint dictionary for @'Disjoint' xs ys@. Used together+-- with 'unsafeCoerceDisjointness' to smuggle the constraint into+-- scope after a value-level overlap check.+data DictDisjoint xs ys where+  DictDisjoint :: (Disjoint xs ys) => DictDisjoint xs ys++-- | Fabricate a 'DictDisjoint' for arbitrary @xs@ and @ys@. The+-- only safe call site is the body of 'Cat..' on+-- 'SomeSymTransducer', after the value-level check has confirmed+-- the slot lists are disjoint. The 'CategoryOverlapError' exception+-- raised on overlap is the *only* safety net; calling this without+-- a prior check can produce a semantically broken composite.+--+-- Implementation: @'Disjoint' '[] '[]@ reduces to the trivially-true+-- constraint @()@, so @DictDisjoint @'[] @'[]@ is always+-- constructible. 'unsafeCoerce' rewrites the existential type+-- arguments to whatever the call site demands.+unsafeCoerceDisjointness ::+  forall xs ys.+  DictDisjoint xs ys+unsafeCoerceDisjointness =+  unsafeCoerce (DictDisjoint :: DictDisjoint '[] '[])++-- | A constraint dictionary witnessing that a slot list satisfies+-- the two structural classes the wrapper packs. Used together with+-- 'unsafeCoerceWrapperDict' to wrap a freshly-composed+-- @SymTransducer ... (Append rs1 rs2) ...@ back into+-- 'SomeSymTransducer' when 'GHC' cannot reduce+-- @WeakenR (Append rs1 rs2)@ / @KnownSlotNames (Append rs1 rs2)@+-- (because the spines @rs1@ and @rs2@ are skolems).+data DictWrapper rs where+  DictWrapper :: (WeakenR rs, KnownSlotNames rs) => DictWrapper rs++-- | Fabricate a 'DictWrapper' for an arbitrary slot list. Both+-- 'WeakenR' and 'KnownSlotNames' are structural classes with+-- automatic instances for every concrete @[Slot]@: whenever both+-- @rs1@ and @rs2@ have these instances, so does @'Append' rs1 rs2@+-- (provable by induction on @rs1@'s spine, which we cannot perform+-- without a value-level witness — hence the 'unsafeCoerce').+--+-- Safe at the 'Cat..' call site because both inner transducers'+-- packed @WeakenR@ + @KnownSlotNames@ constraints already hold for+-- @rs1@ and @rs2@ individually, and the composite slot list+-- @'Append' rs1 rs2@ inherits the structural property.+unsafeCoerceWrapperDict ::+  forall rs.+  DictWrapper rs+unsafeCoerceWrapperDict =+  unsafeCoerce (DictWrapper :: DictWrapper '[])++-- * Category instance --------------------------------------------------++-- | Standard 'Control.Category.Category' instance.+--+-- @'Cat.id'@ is the 'SomeSymIdentity' sentinel constructor; @'Cat..'@+-- short-circuits when either argument is the sentinel, returning the+-- other argument unchanged. The Category laws @id . t = t@ and+-- @t . id = t@ thus hold *by definition* (no behavioural test+-- needed). 'identityTransducer' is the concrete-form identity used+-- by the 'Profunctor' / 'Functor' instances when they need to apply+-- variance combinators to the sentinel; it is not used by 'Cat..'.+--+-- For non-identity composition, @'Cat..'@ delegates to+-- 'Keiki.Composition.compose'. The wrapper hides @rs@, so+-- @compose@'s static @Disjoint (Names rs1) (Names rs2)@ constraint+-- cannot be discharged by GHC; instead, the operator reads each+-- transducer's slot names at the value level via 'KnownSlotNames',+-- checks for overlap, and either:+--+--   * raises 'CategoryOverlapError' (synchronously, on overlap), or+--   * uses 'unsafeCoerceDisjointness' to fabricate the constraint+--     evidence and calls 'compose' with the existential @rs@'s+--     restored as the composite @'Append' rs1 rs2@.+--+-- /Why a sentinel rather than a real identity transducer:/+-- 'Keiki.Composition.compose' substitutes t2's @TInpCtorField ic2@+-- against t1's emitted 'WireCtor' @wc1@ and demands+-- @icName ic2 == wcName wc1@; otherwise it raises a "structural+-- mismatch" runtime error. A *generic* identity transducer (one+-- 'InCtor' that serves every alphabet) cannot satisfy this for+-- arbitrary upstream wire names, so feeding it through 'compose'+-- would always fail. The sentinel sidesteps this by short-circuiting.+--+-- See @test/Keiki/CategorySpec.hs@ for the law tests (behavioural+-- equality on @id . t@, @t . id@, and associativity, plus the+-- 'CategoryOverlapError' path).+instance Cat.Category SomeSymTransducer where+  id = SomeSymIdentity++  SomeSymIdentity . t = t+  t . SomeSymIdentity = t+  SomeSymTransducer t2 . SomeSymTransducer t1 =+    composeWrappers t1 t2++-- | Compose two existentially-packed transducers, performing the+-- runtime overlap check that 'Cat..' delegates to. Factored out so+-- the existential @rs1@ and @rs2@ skolems are bound to named type+-- variables (the instance method's pattern signatures cannot, on+-- their own, name them in a form usable inside 'TypeApplications').+composeWrappers ::+  forall rs1 rs2 s1 s2 ci mid co.+  ( WeakenR rs1,+    KnownSlotNames rs1,+    KnownSlotNames rs2,+    Bounded s1,+    Enum s1,+    Bounded s2,+    Enum s2+  ) =>+  SymTransducer (HsPred rs1 ci) rs1 s1 ci mid ->+  SymTransducer (HsPred rs2 mid) rs2 s2 mid co ->+  SomeSymTransducer ci co+composeWrappers t1 t2 =+  let names1 = slotNames @rs1+      names2 = slotNames @rs2+      overlap = filter (`elem` names2) names1+   in if not (null overlap)+        then throw (CategoryOverlapError overlap)+        else case unsafeCoerceDisjointness @(Names rs1) @(Names rs2) of+          DictDisjoint ->+            case unsafeCoerceWrapperDict @(Append rs1 rs2) of+              DictWrapper -> SomeSymTransducer (compose t1 t2)++-- * Choice instance ----------------------------------------------------++-- | Standard 'Data.Profunctor.Choice.Choice' instance.+--+-- @'left''@ on @t :: 'SomeSymTransducer' a b@ produces a transducer+-- of type @'SomeSymTransducer' (Either a c) (Either b c)@: a @Left a@+-- input is routed through @t@ producing @Left b@; a @Right c@ input+-- passes straight through unchanged. Implemented as+-- @'alternative' t 'identityTransducer'@ — the right arm is the+-- one-vertex identity transducer at alphabet @c@.+--+-- @'right''@ is the symmetric routing: @'alternative' identityTransducer t@.+--+-- /No slot-name overlap risk:/ 'identityTransducer' has @rs = '[]@,+-- so the @'Disjoint' (Names rs) (Names '[])@ side condition on+-- 'alternative' reduces to a vacuous constraint — no+-- 'CategoryOverlapError' path is needed (unlike 'Cat..'). The+-- 'unsafeCoerceDisjointness' call below fabricates the constraint+-- evidence purely because GHC cannot reduce the type family with+-- @rs@ being a skolem; the underlying claim+-- (@Disjoint xs '[]@ is always vacuously true) is sound by the+-- definition of 'Disjoint' in "Keiki.Internal.Slots".+--+-- /Sentinel handling:/ when the input is the 'SomeSymIdentity'+-- sentinel, both @'left''@ and @'right''@ return 'SomeSymIdentity' —+-- @'left'' Cat.id = Cat.id@ at the @Either@ alphabet, by definition+-- of identity. The Choice law @left' Cat.id = Cat.id@ holds *by+-- construction* on the wrapper.+--+-- /Variance caveat:/ inherits 'Keiki.Composition.alternative''s+-- mechanical-inversion preservation: @solveOutput@ on edges produced+-- by @left'@ / @right'@ runs the underlying alternative's+-- @leftInCtor@ / @rightInCtor@ wrappers, which preserve round-trip+-- behaviour. This is *more* preservation than the+-- 'lmapCi' / 'rmapCo' combinators (which poison @icBuild@); the+-- Choice instance does not introduce additional loss.+instance Choice SomeSymTransducer where+  left' ::+    forall a b c.+    SomeSymTransducer a b ->+    SomeSymTransducer (Either a c) (Either b c)+  left' SomeSymIdentity = SomeSymIdentity+  left' (SomeSymTransducer t) = leftWrap t++  right' ::+    forall a b c.+    SomeSymTransducer a b ->+    SomeSymTransducer (Either c a) (Either c b)+  right' SomeSymIdentity = SomeSymIdentity+  right' (SomeSymTransducer t) = rightWrap t++-- | Helper for 'left'' on a wrapped concrete transducer. Factored out+-- to bind the existentially-packed @rs@ and @s@ to named type+-- variables so 'TypeApplications' on 'unsafeCoerceDisjointness' /+-- 'unsafeCoerceWrapperDict' can reach them.+leftWrap ::+  forall rs s ci co c.+  ( WeakenR rs,+    KnownSlotNames rs,+    Bounded s,+    Enum s+  ) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  SomeSymTransducer (Either ci c) (Either co c)+leftWrap t =+  case unsafeCoerceDisjointness @(Names rs) @(Names '[]) of+    DictDisjoint ->+      case unsafeCoerceWrapperDict @(Append rs '[]) of+        DictWrapper ->+          SomeSymTransducer (alternative t (identityTransducer @c))++-- | Helper for 'right'' on a wrapped concrete transducer. Symmetric+-- to 'leftWrap'.+rightWrap ::+  forall rs s ci co c.+  ( WeakenR rs,+    KnownSlotNames rs,+    Bounded s,+    Enum s+  ) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  SomeSymTransducer (Either c ci) (Either c co)+rightWrap t =+  case unsafeCoerceDisjointness @(Names '[]) @(Names rs) of+    DictDisjoint ->+      case unsafeCoerceWrapperDict @(Append '[] rs) of+        DictWrapper ->+          SomeSymTransducer (alternative (identityTransducer @c) t)++-- * Strong instance ----------------------------------------------------++-- | Thread an unrelated value @c@ through a transducer that only+-- knows about @ci -> co@. Implemented from primitives because MP-8+-- declined the general 'parallel' combinator (see+-- @docs/plans/24-composition-combinators-beyond-sequential-design-milestone.md@).+--+-- Implementation walks each edge of @t@:+--+--   * Guards / updates are rewritten via 'contraPred' / 'contraUpdate'+--     with @fst@ as the contramap. The original guards (which test+--     'PInCtor's against @ci@) become guards that test the same+--     'PInCtor's against the @ci@ projection of @(ci, c)@.+--   * Outputs (each @'OPack' ic wc fields@) are rewritten by+--     prepending a @c@-projection field at the head of the+--     'OutFields' chain (read via 'pairSndInCtor') and replacing the+--     'WireCtor' with one that consumes @(c, fs)@ and produces+--     @(co, c)@ — @\\(c, fs) -> (wcBuild wc fs, c)@.+--+-- /Variance caveat:/ same lossy-@solveOutput@ contract as 'lmapCi' /+-- 'rmapCo'. The contramapped 'InCtor's 'icBuild' is poisoned, the+-- new 'WireCtor's 'wcMatch' is @const Nothing@, and 'pairSndInCtor''s+-- 'icBuild' is poisoned. Forward processing+-- ('Keiki.Core.delta', 'Keiki.Core.omega') is unaffected.+firstSym ::+  forall rs s ci co c.+  SymTransducer (HsPred rs ci) rs s ci co ->+  SymTransducer (HsPred rs (ci, c)) rs s (ci, c) (co, c)+firstSym t =+  SymTransducer+    { edgesOut = \s -> map firstEdge (edgesOut t s),+      initial = initial t,+      initialRegs = initialRegs t,+      isFinal = isFinal t+    }+  where+    firstEdge ::+      Edge (HsPred rs ci) rs ci co s ->+      Edge (HsPred rs (ci, c)) rs (ci, c) (co, c) s+    firstEdge Edge {guard = g, update = u, output = mo, target = tgt} =+      Edge+        { guard = contraPred fst g,+          update = contraUpdate fst u,+          output = fmap firstOutTerm mo,+          target = tgt+        }++    -- EP-53: 'OutFields' is now indexed by a single input field schema,+    -- so the threaded-@c@ projection and the original fields must share+    -- one schema. We build a /combined/ 'InCtor' for @(ci, c)@ whose+    -- schema prepends a @"snd"@ slot (carrying @c@) onto the original+    -- constructor's @ifs@, then re-home the original fields' reads into+    -- it (shifting each index past the new head slot). 'firstSym''s+    -- 'solveOutput' stays dead ('firstWireCtor''s @wcMatch@ is+    -- @const Nothing@), so this is correctness-neutral for forward+    -- processing while making the lossy edge well-typed.+    firstOutTerm :: OutTerm rs ci co -> OutTerm rs (ci, c) (co, c)+    firstOutTerm (OPack ic wc fields) =+      let cic = firstInCtor ic+       in OPack cic (firstWireCtor wc) (firstOutFields cic fields)++    firstWireCtor :: forall fs. WireCtor co fs -> WireCtor (co, c) (c, fs)+    firstWireCtor WireCtor {wcName = n, wcBuild = b} =+      WireCtor+        { wcName = n <> "_first",+          wcMatch = \_ -> Nothing,+          wcBuild = \(cv, fs) -> (b fs, cv)+        }++    -- \| Combine an @(ci)@ input constructor with the threaded @c@ into a+    -- @(ci, c)@ constructor whose field schema is @"snd"@ (for @c@)+    -- prepended to the original @ifs@.+    firstInCtor ::+      forall ifs. InCtor ci ifs -> InCtor (ci, c) ('("snd", c) ': ifs)+    firstInCtor ic@InCtor {} =+      InCtor+        { icName = icName ic,+          icMatch = \(civ, cv) -> case icMatch ic civ of+            Just rf -> Just (RCons (Proxy @"snd") cv rf)+            Nothing -> Nothing,+          icBuild = \(RCons _ cv rf) -> (icBuild ic rf, cv)+        }++    firstOutFields ::+      forall ifs fs.+      InCtor (ci, c) ('("snd", c) ': ifs) ->+      OutFields rs ci ifs fs ->+      OutFields rs (ci, c) ('("snd", c) ': ifs) (c, fs)+    firstOutFields cic fields =+      OFCons (TInpCtorField cic ZIdx) (goFields fields)+      where+        goFields ::+          forall fs'.+          OutFields rs ci ifs fs' ->+          OutFields rs (ci, c) ('("snd", c) ': ifs) fs'+        goFields OFNil = OFNil+        goFields (OFCons tm fs') = OFCons (goTerm tm) (goFields fs')++        -- Re-home each read into the combined constructor, shifting the+        -- index past the new @"snd"@ head slot. The original reads name+        -- the edge's one input constructor, so reusing @cic@ (built from+        -- the OPack's 'InCtor') preserves forward semantics.+        goTerm ::+          forall a.+          Term rs ci ifs a ->+          Term rs (ci, c) ('("snd", c) ': ifs) a+        goTerm (TLit r) = TLit r+        goTerm (TReg ix) = TReg ix+        goTerm (TInpCtorField _ ix) = TInpCtorField cic (SIdx ix)+        goTerm (TApp1 h a) = TApp1 h (goTerm a)+        goTerm (TApp2 h a b) = TApp2 h (goTerm a) (goTerm b)+        goTerm (TArith op a b) = TArith op (goTerm a) (goTerm b)++-- | Standard 'Data.Profunctor.Strong.Strong' instance. Threads an+-- unrelated value through a transducer.+--+-- @'first''@ delegates to 'firstSym' on a wrapped concrete+-- transducer; on the 'SomeSymIdentity' sentinel it returns+-- 'SomeSymIdentity' (since @(a, c) -> (a, c)@ is identity).+--+-- @'second''@ is derived via @swap@: @second' = lmap swap . first' . rmap swap@,+-- which compiles to one extra contramap pair around the @firstSym@+-- core. A direct @secondSym@ implementation could shave the two+-- rewrites for ~10% better build cost, but the current shape keeps+-- the symmetry obvious and the implementation small.+--+-- /Variance caveat:/ inherits 'firstSym''s lossy-@solveOutput@+-- contract.+instance Strong SomeSymTransducer where+  first' ::+    forall a b c.+    SomeSymTransducer a b ->+    SomeSymTransducer (a, c) (b, c)+  first' SomeSymIdentity = SomeSymIdentity+  first' (SomeSymTransducer t) = SomeSymTransducer (firstSym t)++  second' ::+    forall a b c.+    SomeSymTransducer a b ->+    SomeSymTransducer (c, a) (c, b)+  second' SomeSymIdentity = SomeSymIdentity+  second' (SomeSymTransducer t) =+    SomeSymTransducer+      (lmapCi swap (rmapCo swap (firstSym t)))+    where+      swap :: forall x y. (x, y) -> (y, x)+      swap (x, y) = (y, x)++-- * Arrow instance ------------------------------------------------------++-- | A stateless one-edge transducer that lifts an arbitrary Haskell+-- function. Used by the 'Arr.Arrow' instance's 'Arr.arr' method.+--+-- Construction: one vertex ('IdVertex'); one edge whose guard is+-- @'PInCtor' 'identityInCtor'@ (always-fires standalone, but+-- arm-discriminating when lifted by 'Keiki.Composition.alternative'+-- — see 'identityTransducer' for the same lesson); the edge's+-- 'WireCtor's 'wcBuild' applies @f@ to the read input.+--+-- /Variance caveat:/ same lossy-@solveOutput@ contract as+-- 'lmapCi' / 'rmapCo' / 'firstSym'. The 'WireCtor's 'wcMatch' is+-- @const Nothing@ — there is no inverse function in general.+-- Forward processing ('Keiki.Core.delta', 'Keiki.Core.omega') is+-- unaffected.+--+-- /Composition limitation:/ 'Keiki.Composition.compose' substitutes+-- t2's 'TInpCtorField' against t1's 'WireCtor'-emitted output and+-- demands 'icName ic2 == wcName wc1'. An 'arrTransducer'-produced+-- transducer's 'WireCtor' is named @"arr"@ but the next stage's+-- 'TInpCtorField' uses 'identityInCtor' (named @"Identity"@), so+-- 'arr f >>> arr g' will not produce 'arr (g . f)' through 'Cat..'+-- — substitution turns the composed guard into 'PBot' and the+-- composite never fires. This is documented rather than worked+-- around because the symbolic 'Term' AST has no+-- 'TPure'-style constructor for arbitrary function application+-- (intentional; see 'Keiki.Symbolic.translateTermSym' for why+-- function applications would be untranslatable). Use 'Arr.arr'+-- standalone for adapter purposes; for actual composition, build+-- one transducer that wraps the combined function.+arrTransducer ::+  forall a b.+  (a -> b) ->+  SymTransducer (HsPred '[] a) '[] IdVertex a b+arrTransducer f =+  SymTransducer+    { edgesOut = \IdVertex ->+        [ Edge+            { guard = PInCtor identityInCtor,+              update = UKeep,+              output = [arrOut],+              target = IdVertex+            }+        ],+      initial = IdVertex,+      initialRegs = RNil,+      isFinal = const True+    }+  where+    arrOut :: OutTerm '[] a b+    arrOut =+      OPack+        identityInCtor+        arrWc+        (OFCons (TInpCtorField identityInCtor ZIdx) OFNil)++    arrWc :: WireCtor b (a, ())+    arrWc =+      WireCtor+        { wcName = "arr",+          wcMatch = \_ -> Nothing,+          wcBuild = \(a, ()) -> f a+        }++-- | Standard 'Control.Arrow.Arrow' instance.+--+-- @'Arr.arr' f@ wraps 'arrTransducer' (a stateless one-edge+-- transducer with @'wcBuild' = \\(a, ()) -> f a@). @'Arr.first'@+-- delegates to 'Strong.first''; @'Arr.second'@ delegates to+-- 'Strong.second''. @'Arr.>>>'@ and @'Arr.<<<'@ inherit the+-- 'Cat.Category' instance's runtime overlap check + sentinel+-- short-circuit.+--+-- The default @'***'@ and @'&&&'@ methods of 'Arr.Arrow' use+-- 'Arr.arr', 'Arr.first', and 'Arr.>>>' under the hood; they+-- typecheck and produce composite transducers. The same+-- @icName == wcName@ alignment limitation that affects+-- 'arr f >>> arr g' applies — see 'arrTransducer' for the full+-- caveat.+instance Arr.Arrow SomeSymTransducer where+  arr f = SomeSymTransducer (arrTransducer f)+  first = first'+  second = second'++-- * Internal rewriters --------------------------------------------------++-- These walk the closed AST of 'Edge', 'HsPred', 'Update', 'Term',+-- 'OutTerm', 'OutFields', 'InCtor', and 'WireCtor', threading a+-- contramap on @ci@ (or a covariant map on @co@) through every+-- position the type parameter occupies.++-- | Contramap an 'InCtor' over its alphabet. The resulting 'InCtor's+-- 'icBuild' is poisoned: callers must not invoke+-- 'Keiki.Core.solveOutput' on edges built from this 'InCtor'.+contraInCtor :: (ci' -> ci) -> InCtor ci ifs -> InCtor ci' ifs+contraInCtor f InCtor {icName = n, icMatch = m} =+  InCtor+    { icName = n,+      icMatch = m . f,+      icBuild = poisonedIcBuild n+    }++-- | Partial-contramap an 'InCtor'. The 'icMatch' becomes+-- @\ci' -> f ci' >>= m@; 'icBuild' is poisoned (same caveat as+-- 'contraInCtor').+contraMaybeInCtor :: (ci' -> Maybe ci) -> InCtor ci ifs -> InCtor ci' ifs+contraMaybeInCtor f InCtor {icName = n, icMatch = m} =+  InCtor+    { icName = n,+      icMatch = \ci' -> f ci' >>= m,+      icBuild = poisonedIcBuild n+    }++poisonedIcBuild :: String -> a -> b+poisonedIcBuild icN = \_ ->+  error+    ( "Keiki.Profunctor: icBuild on a contramapped InCtor \""+        <> icN+        <> "\" was invoked. lmapCi/lmapMaybeCi-rewritten transducers \+           \cannot rebuild ci from a wire event via solveOutput. See \+           \the haddock for Keiki.Profunctor.lmapCi."+    )++-- | Covariant map a 'WireCtor' over its alphabet. The resulting+-- 'WireCtor's 'wcMatch' is set to @const Nothing@.+mapWireCtor :: (co -> co') -> WireCtor co fs -> WireCtor co' fs+mapWireCtor g WireCtor {wcName = n, wcBuild = b} =+  WireCtor+    { wcName = n,+      wcMatch = \_co' -> Nothing,+      wcBuild = g . b+    }++-- ** Term ---------------------------------------------------------------++contraTerm :: forall ci ci' rs ifs r. (ci' -> ci) -> Term rs ci ifs r -> Term rs ci' ifs r+contraTerm f = go+  where+    go :: forall a. Term rs ci ifs a -> Term rs ci' ifs a+    go (TLit r) = TLit r+    go (TReg ix) = TReg ix+    go (TInpCtorField ic ix) = TInpCtorField (contraInCtor f ic) ix+    go (TApp1 h a) = TApp1 h (go a)+    go (TApp2 h a b) = TApp2 h (go a) (go b)+    go (TArith op a b) = TArith op (go a) (go b)++contraMaybeTerm :: forall ci ci' rs ifs r. (ci' -> Maybe ci) -> Term rs ci ifs r -> Term rs ci' ifs r+contraMaybeTerm f = go+  where+    go :: forall a. Term rs ci ifs a -> Term rs ci' ifs a+    go (TLit r) = TLit r+    go (TReg ix) = TReg ix+    go (TInpCtorField ic ix) = TInpCtorField (contraMaybeInCtor f ic) ix+    go (TApp1 h a) = TApp1 h (go a)+    go (TApp2 h a b) = TApp2 h (go a) (go b)+    go (TArith op a b) = TArith op (go a) (go b)++-- ** HsPred -------------------------------------------------------------++contraPred :: forall ci ci' rs. (ci' -> ci) -> HsPred rs ci -> HsPred rs ci'+contraPred f = go+  where+    go :: HsPred rs ci -> HsPred rs ci'+    go PTop = PTop+    go PBot = PBot+    go (PAnd p q) = PAnd (go p) (go q)+    go (POr p q) = POr (go p) (go q)+    go (PNot p) = PNot (go p)+    go (PEq a b) = PEq (contraTerm f a) (contraTerm f b)+    go (PInCtor ic) = PInCtor (contraInCtor f ic)+    go (PCmp op a b) = PCmp op (contraTerm f a) (contraTerm f b)++contraMaybePred :: forall ci ci' rs. (ci' -> Maybe ci) -> HsPred rs ci -> HsPred rs ci'+contraMaybePred f = go+  where+    go :: HsPred rs ci -> HsPred rs ci'+    go PTop = PTop+    go PBot = PBot+    go (PAnd p q) = PAnd (go p) (go q)+    go (POr p q) = POr (go p) (go q)+    go (PNot p) = PNot (go p)+    go (PEq a b) = PEq (contraMaybeTerm f a) (contraMaybeTerm f b)+    go (PInCtor ic) = PInCtor (contraMaybeInCtor f ic)+    go (PCmp op a b) = PCmp op (contraMaybeTerm f a) (contraMaybeTerm f b)++-- ** Update -------------------------------------------------------------++contraUpdate :: forall ci ci' rs w. (ci' -> ci) -> Update rs w ci -> Update rs w ci'+contraUpdate f = go+  where+    go :: forall w'. Update rs w' ci -> Update rs w' ci'+    go UKeep = UKeep+    go (USet ixn term) = USet ixn (contraTerm f term)+    go (UCombine u1 u2) = UCombine (go u1) (go u2)++contraMaybeUpdate :: forall ci ci' rs w. (ci' -> Maybe ci) -> Update rs w ci -> Update rs w ci'+contraMaybeUpdate f = go+  where+    go :: forall w'. Update rs w' ci -> Update rs w' ci'+    go UKeep = UKeep+    go (USet ixn term) = USet ixn (contraMaybeTerm f term)+    go (UCombine u1 u2) = UCombine (go u1) (go u2)++-- ** OutTerm + OutFields -----------------------------------------------++contraOutTerm :: (ci' -> ci) -> OutTerm rs ci co -> OutTerm rs ci' co+contraOutTerm f (OPack ic wc fields) =+  OPack (contraInCtor f ic) wc (contraOutFields f fields)++contraOutFields :: forall ci ci' rs ifs fs. (ci' -> ci) -> OutFields rs ci ifs fs -> OutFields rs ci' ifs fs+contraOutFields f = go+  where+    go :: forall fs'. OutFields rs ci ifs fs' -> OutFields rs ci' ifs fs'+    go OFNil = OFNil+    go (OFCons t fs) = OFCons (contraTerm f t) (go fs)++contraMaybeOutTerm :: (ci' -> Maybe ci) -> OutTerm rs ci co -> OutTerm rs ci' co+contraMaybeOutTerm f (OPack ic wc fields) =+  OPack (contraMaybeInCtor f ic) wc (contraMaybeOutFields f fields)++contraMaybeOutFields :: forall ci ci' rs ifs fs. (ci' -> Maybe ci) -> OutFields rs ci ifs fs -> OutFields rs ci' ifs fs+contraMaybeOutFields f = go+  where+    go :: forall fs'. OutFields rs ci ifs fs' -> OutFields rs ci' ifs fs'+    go OFNil = OFNil+    go (OFCons t fs) = OFCons (contraMaybeTerm f t) (go fs)++-- | Covariant map of a single OPack over its co alphabet.+mapOutTermCo :: (co -> co') -> OutTerm rs ci co -> OutTerm rs ci co'+mapOutTermCo g (OPack ic wc fields) =+  OPack ic (mapWireCtor g wc) fields++-- ** Edge ---------------------------------------------------------------++rewriteEdge :: (ci' -> ci) -> Edge (HsPred rs ci) rs ci co s -> Edge (HsPred rs ci') rs ci' co s+rewriteEdge f Edge {guard = g, update = u, output = mo, target = tgt} =+  Edge+    { guard = contraPred f g,+      update = contraUpdate f u,+      output = fmap (contraOutTerm f) mo,+      target = tgt+    }++rewriteEdgeMaybe ::+  (ci' -> Maybe ci) ->+  Edge (HsPred rs ci) rs ci co s ->+  Edge (HsPred rs ci') rs ci' co s+rewriteEdgeMaybe f Edge {guard = g, update = u, output = mo, target = tgt} =+  Edge+    { guard = contraMaybePred f g,+      update = contraMaybeUpdate f u,+      output = fmap (contraMaybeOutTerm f) mo,+      target = tgt+    }++rewriteEdgeOut ::+  (co -> co') ->+  Edge (HsPred rs ci) rs ci co s ->+  Edge (HsPred rs ci) rs ci co' s+rewriteEdgeOut g Edge {guard = guardP, update = u, output = mo, target = tgt} =+  Edge+    { guard = guardP,+      update = u,+      output = fmap (mapOutTermCo g) mo,+      target = tgt+    }
+ src/Keiki/Render/Inspector.hs view
@@ -0,0 +1,224 @@+-- | A Markdown edge-detail renderer for 'SymTransducer', a sibling to+-- the Mermaid topology renderer in "Keiki.Render.Mermaid". Where+-- 'Keiki.Render.Mermaid.toMermaid' shows the /shape/ of a workflow (one+-- line per edge), this renderer lays out every edge in /full/: its+-- source and target states, its 0-based edge index, the input+-- (command) constructor, the output (event) constructor(s), the guard+-- predicate (structural and/or domain-readable), the register slots it+-- writes, and — optionally — each output field's term.+--+-- The output is a deterministic 'Data.Text.Text' Markdown document with+-- edges grouped under a level-3 heading per source state. It is pure:+-- no IO, no SMT solver.+module Keiki.Render.Inspector+  ( EdgeInspectorOptions (..),+    defaultEdgeInspectorOptions,+    renderEdgeInspector,+  )+where++import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Core+  ( Edge (..),+    HsPred (..),+    OutFields (..),+    OutTerm (..),+    SymTransducer (..),+    Update (..),+    WireCtor (..),+  )+import Keiki.Internal.Slots (indexNName)+import Keiki.Render.Mermaid (edgeInputName)+import Keiki.Render.Pretty (prettyPred, prettyTerm)++-- | Which detail fields each edge block carries. Every field is opt-in+-- via a 'Bool'. 'defaultEdgeInspectorOptions' turns on everything that+-- needs no domain-readable rendering; the two pretty options+-- ('includePrettyGuard', 'includeOutputFields') reuse+-- "Keiki.Render.Pretty" and default to 'False'.+data EdgeInspectorOptions = EdgeInspectorOptions+  { -- | Show @edge index: N@ (the 0-based position in @edgesOut t s@).+    includeEdgeIndex :: Bool,+    -- | Show the structural guard summary, e.g. @PAnd PInCtor PEq@.+    includeStructuralGuard :: Bool,+    -- | Show the domain-readable guard from+    --     'Keiki.Render.Pretty.prettyPred', e.g.+    --     @(ConfirmAccount && ConfirmAccount.confirmCode == confirmCode)@.+    includePrettyGuard :: Bool,+    -- | Show the register slots the edge writes.+    includeWrittenSlots :: Bool,+    -- | Show each output field's term, positionally (field 0, field 1,+    --     …), via 'Keiki.Render.Pretty.prettyTerm'. 'WireCtor' carries no+    --     field names, so fields are labelled by position only.+    includeOutputFields :: Bool+  }++-- | The default: everything on except the two pretty options that reuse+-- "Keiki.Render.Pretty".+defaultEdgeInspectorOptions :: EdgeInspectorOptions+defaultEdgeInspectorOptions =+  EdgeInspectorOptions+    { includeEdgeIndex = True,+      includeStructuralGuard = True,+      includePrettyGuard = False,+      includeWrittenSlots = True,+      includeOutputFields = False+    }++-- | Render a 'SymTransducer' to a Markdown edge-detail document. Edges+-- are grouped under a @### \<state\>@ heading per source state, in+-- @[minBound .. maxBound]@ order; states with no outgoing edges produce+-- no section. The state type's @Bounded@/@Enum@ enumerate the states and+-- @Show@ names them, mirroring 'Keiki.Render.Mermaid.toMermaid'.+renderEdgeInspector ::+  (Bounded s, Enum s, Show s) =>+  EdgeInspectorOptions ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  Text+renderEdgeInspector opts t =+  let states = [minBound .. maxBound]+      section s = case edgesOut t s of+        [] -> Nothing+        edges -> Just (renderState opts s edges)+   in T.intercalate+        (T.pack "\n\n")+        ( T.pack "# Edge inspector"+            : [blk | Just blk <- map section states]+        )++-- | One @### \<state\>@ section: the heading, a blank line, then one+-- block per outgoing edge (in @edgesOut@ order, with its 0-based index).+-- Edge blocks are separated by a single newline (no blank line between+-- them).+renderState ::+  (Show s) =>+  EdgeInspectorOptions ->+  s ->+  [Edge (HsPred rs ci) rs ci co s] ->+  Text+renderState opts s edges =+  T.intercalate+    (T.pack "\n")+    ( (T.pack "### " <> T.pack (show s))+        : T.pack ""+        : [renderEdge opts s i e | (i, e) <- zip [0 ..] edges]+    )++-- | One edge block: a header bullet naming the transition, then one+-- indented detail bullet per enabled, non-empty field. @update@ is bound+-- by the 'Edge' pattern (never via the @update@ selector) so the+-- existential write-set does not escape.+renderEdge ::+  (Show s) =>+  EdgeInspectorOptions ->+  s ->+  Int ->+  Edge (HsPred rs ci) rs ci co s ->+  Text+renderEdge opts s i e@Edge {guard = g, update = u, target = tgt} =+  T.intercalate (T.pack "\n") (header : details)+  where+    header =+      T.pack "- **"+        <> T.pack (show s)+        <> T.pack " -> "+        <> T.pack (show tgt)+        <> T.pack "**"++    details =+      concat+        [ bullet+            (includeEdgeIndex opts)+            (T.pack "edge index: " <> T.pack (show i)),+          [detail (T.pack "input: " <> maybe (T.pack "?") id (edgeInputName e))],+          [detail (T.pack "output: " <> maybe (T.pack "\x03B5") id (outputName e))],+          outputFieldsBullets,+          bullet+            (includeStructuralGuard opts)+            (T.pack "guard (structural): " <> guardSummary g),+          bullet+            (includePrettyGuard opts)+            (T.pack "guard (pretty): " <> prettyPred g),+          writtenBullets+        ]++    -- An edge's written-slot listing; omitted when the edge writes+    -- nothing (an empty list would be noise).+    writtenBullets+      | not (includeWrittenSlots opts) = []+      | otherwise = case writtenSlots u of+          [] -> []+          ws -> [detail (T.pack "written slots: " <> T.intercalate (T.pack "; ") ws)]++    -- Each output's fields, positionally. Only outputs that have at+    -- least one field contribute; the bullet is omitted when no output+    -- carries a field.+    outputFieldsBullets+      | not (includeOutputFields opts) = []+      | otherwise = case [grp | Just grp <- map outputGroup (output e)] of+          [] -> []+          grps -> [detail (T.pack "output fields: " <> T.intercalate (T.pack "; ") grps)]++    detail x = T.pack "  - " <> x+    bullet cond x = if cond then [detail x] else []++-- | One output's field listing: @\<wcName\>[field 0: t0; field 1: t1]@,+-- or 'Nothing' when the output constructor has no fields.+outputGroup :: OutTerm rs ci co -> Maybe Text+outputGroup (OPack _ wc fs) = case zip [0 :: Int ..] (prettyOutFields fs) of+  [] -> Nothing+  fields ->+    Just+      ( T.pack (wcName wc)+          <> T.pack "["+          <> T.intercalate+            (T.pack "; ")+            [ T.pack "field " <> T.pack (show k) <> T.pack ": " <> ft+            | (k, ft) <- fields+            ]+          <> T.pack "]"+      )++-- | Pretty-print each field 'Term' of an 'OutFields' HList, in order,+-- reusing 'Keiki.Render.Pretty.prettyTerm'.+prettyOutFields :: OutFields rs ci ifs fs -> [Text]+prettyOutFields OFNil = []+prettyOutFields (OFCons t rest) = prettyTerm t : prettyOutFields rest++-- | The output constructor name(s) for an edge, joined with @"; "@ for+-- Markdown (the Mermaid renderer uses @\<br/\>@ for three or more, which+-- is a diagram-only line break). 'Nothing' for an ε-edge (empty output).+outputName :: Edge (HsPred rs ci) rs ci co s -> Maybe Text+outputName Edge {output = outs} = case outs of+  [] -> Nothing+  many -> Just (T.intercalate (T.pack "; ") (map wcN many))+  where+    wcN :: OutTerm rs ci co -> Text+    wcN (OPack _ wc _) = T.pack (wcName wc)++-- | A structural, total summary of a guard predicate: its constructor+-- tags in left-to-right (prefix) order, with 'PCmp' carrying its+-- direction. Replicated from "Keiki.Render.Mermaid" (where it is not+-- exported); kept byte-identical to that original.+guardSummary :: HsPred rs ci -> Text+guardSummary = T.intercalate (T.pack " ") . go+  where+    go :: HsPred rs ci -> [Text]+    go PTop = [T.pack "PTop"]+    go PBot = [T.pack "PBot"]+    go (PAnd a b) = T.pack "PAnd" : go a ++ go b+    go (POr a b) = T.pack "POr" : go a ++ go b+    go (PNot p) = T.pack "PNot" : go p+    go (PEq _ _) = [T.pack "PEq"]+    go (PInCtor _) = [T.pack "PInCtor"]+    go (PCmp c _ _) = [T.pack "PCmp " <> T.pack (show c)]++-- | Recover the names of the slots an edge's 'Update' writes.+-- Replicated from "Keiki.Render.Mermaid" (not exported there); kept+-- byte-identical. 'USet's @KnownSymbol s@ (from the pattern match) lets+-- 'indexNName' read the slot name off the index.+writtenSlots :: Update rs w ci -> [Text]+writtenSlots UKeep = []+writtenSlots (USet ix _) = [T.pack (indexNName ix)]+writtenSlots (UCombine a b) = writtenSlots a ++ writtenSlots b
+ src/Keiki/Render/Markdown.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE MultiWayIf #-}++-- | Generic Markdown marker-replacement helper. References no keiki+-- type: it rewrites a marked fenced block inside an arbitrary Markdown+-- document. The marker convention is a matched pair of HTML comments,+-- @\<!-- {namespace}: {id} begin --\>@ and @\<!-- {namespace}: {id} end --\>@.+--+-- This closes the loop on regenerating a diagram document: a section+-- emitted by @'Keiki.Render.Mermaid.toMermaidAtlasWith'@ with+-- @atlasWrapMarkers = Just ns@ produces exactly these markers (keyed by the+-- section's @sectionId@), so 'replaceMarkdownDiagramBlock' can later refresh+-- that one block in place while preserving every byte outside it.+--+-- See @docs/plans/65-mermaid-diagram-atlas-sections-and-markdown-marker-replacement-helper.md@.+module Keiki.Render.Markdown+  ( MarkdownDiagramBlock (..),+    MarkdownDiagramError (..),+    replaceMarkdownDiagramBlock,+    beginMarker,+    endMarker,+  )+where++import Data.Text (Text)+import Data.Text qualified as T++-- | A diagram block to splice into a document. 'blockContent' is the+-- already-rendered block body (no fences); 'replaceMarkdownDiagramBlock'+-- wraps it in a normalized fenced block tagged with 'blockLanguage'.+data MarkdownDiagramBlock = MarkdownDiagramBlock+  { -- | Marker namespace, e.g. a service name.+    blockNamespace :: Text,+    -- | Marker id; the atlas @sectionId@.+    blockId :: Text,+    -- | Fenced-block language tag, e.g. @"mermaid"@.+    blockLanguage :: Text,+    -- | Already-rendered block body (no fences).+    blockContent :: Text+  }+  deriving stock (Eq, Show)++-- | Why a replacement could not be performed. Each carries enough text+-- to print the expected marker.+data MarkdownDiagramError+  = -- | The expected begin marker text, not found in the document.+    MissingBeginMarker Text+  | -- | The expected end marker text, not found in the document.+    MissingEndMarker Text+  | -- | A marker text found more than once, and the count found.+    DuplicateMarker Text Int+  deriving stock (Eq, Show)++-- | The begin marker for a @(namespace, id)@ pair.+beginMarker :: Text -> Text -> Text+beginMarker ns i =+  T.pack "<!-- " <> ns <> T.pack ": " <> i <> T.pack " begin -->"++-- | The end marker for a @(namespace, id)@ pair.+endMarker :: Text -> Text -> Text+endMarker ns i =+  T.pack "<!-- " <> ns <> T.pack ": " <> i <> T.pack " end -->"++-- | Replace everything between the begin and end markers for+-- @(blockNamespace, blockId)@ with a normalized fenced block. Preserves+-- the markers and every byte outside them.+--+-- The normalized block is+-- @```{blockLanguage}\\n{content}\\n```@ where @content@ is+-- 'blockContent' with trailing newlines stripped, placed on its own lines+-- between the (preserved) begin and end markers. Because the trailing+-- newlines are stripped before the closing fence, the helper is+-- __idempotent__: re-applying it to a document it already produced yields+-- the identical document.+--+-- Validation: exactly one begin and one end marker must be present.+-- A missing begin marker yields @'MissingBeginMarker' begin@; a missing+-- end yields @'MissingEndMarker' end@; a repeated marker yields+-- @'DuplicateMarker' marker count@.+replaceMarkdownDiagramBlock ::+  MarkdownDiagramBlock -> Text -> Either MarkdownDiagramError Text+replaceMarkdownDiagramBlock blk doc =+  let b = beginMarker (blockNamespace blk) (blockId blk)+      e = endMarker (blockNamespace blk) (blockId blk)+      nb = T.count b doc+      ne = T.count e doc+   in if+        | nb == 0 -> Left (MissingBeginMarker b)+        | nb > 1 -> Left (DuplicateMarker b nb)+        | ne == 0 -> Left (MissingEndMarker e)+        | ne > 1 -> Left (DuplicateMarker e ne)+        | otherwise ->+            let (pre, restB) = T.breakOn b doc+                afterBegin = T.drop (T.length b) restB+                (_, post) = T.breakOn e afterBegin+                fenced =+                  T.pack "```"+                    <> blockLanguage blk+                    <> T.pack "\n"+                    <> stripTrailingNewlines (blockContent blk)+                    <> T.pack "\n```"+             in Right (pre <> b <> T.pack "\n" <> fenced <> T.pack "\n" <> post)++-- | Drop any run of trailing @'\\n'@ characters.+stripTrailingNewlines :: Text -> Text+stripTrailingNewlines = T.dropWhileEnd (== '\n')
+ src/Keiki/Render/Mermaid.hs view
@@ -0,0 +1,1116 @@+-- | Mermaid 'stateDiagram-v2' renderer for 'SymTransducer' values whose+-- vertex type is enumerable.+--+-- The single-transducer entry point is 'toMermaid'; the supporting+-- helpers ('vertexLabel', 'edgeInputName', 'edgeOutputName',+-- 'edgeLabel') are exported so callers can build custom rendering+-- pipelines on top of the same primitives.+--+-- The rendered output is a @stateDiagram-v2@ block as 'Data.Text.Text'.+-- It can be pasted into a Markdown file or Notion page; GitHub renders+-- Mermaid blocks inline so PR reviewers see the topology diff alongside+-- the source diff.+--+-- The renderer is specialised to @phi ~ 'HsPred' rs ci@ — extracting+-- the input-constructor name from an edge guard requires walking the+-- guard's AST, and 'HsPred' is the only first-class guard AST in the+-- repository. See the Decision Log of+-- @docs/plans/30-mermaid-renderer-for-single-symtransducer-canonical-example-diagrams.md@+-- for the rationale.+--+-- See also:+--+--   * @docs/masterplans/10-mermaid-topology-renderer-for-symtransducer.md@+--     for the initiative motivation.+module Keiki.Render.Mermaid+  ( toMermaid,+    toMermaidAlternative,+    toMermaidAlternativeWith,+    toMermaidComposite,+    toMermaidCompositeNested,+    toMermaidCompose3,+    toMermaidCompose3Nested,+    toMermaidFeedback1,+    toMermaidAtlas,+    toMermaidAtlasWith,+    MermaidSection (..),+    MermaidSectionKind (..),+    MermaidAtlasOptions (..),+    AtlasKindDisplay (..),+    defaultMermaidAtlasOptions,+    toMermaidWith,+    toMermaidWithLabels,+    MermaidOptions (..),+    MermaidGuardMode (..),+    MermaidLabelLayout (..),+    MermaidOutputLayout (..),+    MermaidStateLabels (..),+    duplicateStateIds,+    defaultMermaidOptions,+    vertexLabel,+    compositeLabel,+    compose3Label,+    edgeInputName,+    edgeOutputName,+    edgeLabel,+  )+where++import Control.Applicative ((<|>))+import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Composition (Composite (..), WeakenR, feedback1)+import Keiki.Core+  ( Disjoint,+    Edge (..),+    HsPred (..),+    InCtor (..),+    Names,+    OutTerm (..),+    SymTransducer (..),+    Update (..),+    WireCtor (..),+  )+import Keiki.Generics (Append)+import Keiki.Internal.Slots (indexNName)+import Keiki.Render.Pretty (prettyPred)++-- | How an edge's guard predicate is rendered into the @[g: …]@+-- segment.+--+--   * 'MermaidGuardHidden' — no guard segment at all.+--   * 'MermaidGuardStructuralSummary' — the structural constructor-tag+--     walk produced by 'guardSummary', e.g. @PAnd PInCtor PEq@. This is+--     the legacy rendering that the 'showGuardSummary' flag selects.+--   * 'MermaidGuardPretty' — the domain-readable rendering produced by+--     'Keiki.Render.Pretty.prettyPred', e.g.+--     @(ConfirmAccount && ConfirmAccount.confirmCode == confirmCode)@.+data MermaidGuardMode+  = MermaidGuardHidden+  | MermaidGuardStructuralSummary+  | MermaidGuardPretty+  deriving stock (Eq, Show)++-- | How dense edge labels are laid out.+--+--   * 'MermaidLabelInline' — the current single-line @[seg; seg]@ form.+--   * 'MermaidLabelMultiline' — the base on line one; each further+--     segment on its own @<br/>@-separated line.+data MermaidLabelLayout+  = MermaidLabelInline+  | MermaidLabelMultiline+  deriving stock (Eq, Show)++-- | How an edge that emits several events renders its output names.+--+--   * 'MermaidOutputSemicolon' — today's length-based default: @;@ for+--     exactly two events, @<br/>@ for three or more.+--   * 'MermaidOutputMultiline' — always one event per line+--     (@<br/>@-joined), regardless of count.+--   * 'MermaidOutputCounted' — a compact @N events@ count for two or+--     more (a single event still renders as its name; an ε-edge stays+--     @ε@).+data MermaidOutputLayout+  = MermaidOutputSemicolon+  | MermaidOutputMultiline+  | MermaidOutputCounted+  deriving stock (Eq, Show)++-- | Rendering options for the structural edge-summary suffix. All+-- fields default to the no-suffix setting in 'defaultMermaidOptions', so+-- the default rendering is byte-identical to 'toMermaid'.+--+-- The record is extended /additively/: new fields are appended with a+-- default that reproduces the existing behaviour, and existing fields+-- are never removed or reordered. The legacy 'showGuardSummary' flag and+-- the newer 'guardMode' field are reconciled by 'renderGuardSegment' (an+-- explicit 'guardMode' wins; otherwise 'showGuardSummary' is honoured as+-- the legacy spelling of 'MermaidGuardStructuralSummary').+data MermaidOptions = MermaidOptions+  { -- | When 'True', append the update's written-slot names, e.g.+    --     @[w: email; confirmCode; registeredAt]@.+    showWrittenSlots :: Bool,+    -- | When 'True', append a structural guard summary listing the+    --     guard's constructor / comparison tags, e.g. @[g: PAnd PInCtor PEq]@.+    --     This is the legacy spelling of @'guardMode' = 'MermaidGuardStructuralSummary'@;+    --     it is honoured only when 'guardMode' is left at its default+    --     ('MermaidGuardHidden').+    showGuardSummary :: Bool,+    -- | How the guard segment is rendered. When set to anything other+    --     than 'MermaidGuardHidden', it takes precedence over the legacy+    --     'showGuardSummary' flag. Defaults to 'MermaidGuardHidden'.+    guardMode :: MermaidGuardMode,+    -- | Inline (default, byte-identical) or multiline @<br/>@ layout+    --     of an edge label's segments. Defaults to 'MermaidLabelInline'.+    labelLayout :: MermaidLabelLayout,+    -- | When @'Just' k@ and an edge writes @n > k@ slots, show the+    --     first @k@ then a single @+{n-k} more@ token. 'Nothing' (the+    --     default) disables truncation.+    maxInlineWrittenSlots :: Maybe Int,+    -- | When @'Just' w@ and the guard segment text exceeds @w@+    --     characters, take @w@ characters then append the ellipsis @…@.+    --     'Nothing' (the default) disables truncation.+    maxInlineGuardWidth :: Maybe Int,+    -- | How a multi-event edge renders its output names. Defaults to+    --     'MermaidOutputSemicolon', which reproduces today's length-based+    --     behaviour exactly.+    outputLayout :: MermaidOutputLayout+  }++-- | The default: no summary suffix. @'toMermaid' t@ equals+-- @'toMermaidWith' 'defaultMermaidOptions' t@.+defaultMermaidOptions :: MermaidOptions+defaultMermaidOptions =+  MermaidOptions+    { showWrittenSlots = False,+      showGuardSummary = False,+      guardMode = MermaidGuardHidden,+      labelLayout = MermaidLabelInline,+      maxInlineWrittenSlots = Nothing,+      maxInlineGuardWidth = Nothing,+      outputLayout = MermaidOutputSemicolon+    }++-- | Render a 'SymTransducer' to a Mermaid @stateDiagram-v2@ block.+--+-- The vertex type @s@ must derive 'Enum', 'Bounded', and 'Show'. The+-- enumeration walks @[minBound .. maxBound]@; vertex labels come from+-- 'show'. The output begins with @stateDiagram-v2@, followed by an+-- initial-state line (@[*] --> <initial>@), one line per outgoing+-- edge of every vertex, and a final-state line (@<vertex> --> [*]@)+-- for every vertex where 'isFinal' returns 'True'. Edge labels follow+-- the format described by 'edgeLabel'.+toMermaid ::+  (Enum s, Bounded s, Show s) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  Text+toMermaid = toMermaidWith defaultMermaidOptions++-- | Like 'toMermaid', but takes 'MermaidOptions' controlling the+-- structural edge-summary suffix. @'toMermaidWith' 'defaultMermaidOptions'@+-- is byte-identical to 'toMermaid'. With 'showWrittenSlots' and/or+-- 'showGuardSummary' enabled, each edge label gains a compact bracketed+-- suffix, e.g. @… [w: email; confirmCode; registeredAt; g: PAnd PInCtor PTop]@.+--+-- Only the single-transducer path is annotated; the composite renderers+-- ('toMermaidComposite' and relatives) keep the guard-free default.+toMermaidWith ::+  (Enum s, Bounded s, Show s) =>+  MermaidOptions ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  Text+toMermaidWith opts = renderTopologyWith opts vertexLabel vertexLabel++-- | A pair of per-vertex label functions for 'toMermaidWithLabels'.+--+--   * 'stateId' produces the stable ASCII Mermaid identifier used as a+--     node id and in every transition arrow. It is the caller's+--     responsibility to return a legal Mermaid identifier+--     (@[A-Za-z_][A-Za-z0-9_]*@); keiki uses it verbatim and does not+--     sanitise it.+--   * 'stateDisplayLabel' produces the friendly visible label, which may+--     contain spaces. When the display differs from the id for a vertex,+--     the renderer emits a @state \"<display>\" as <id>@ declaration; when+--     they are equal it emits nothing extra, so feeding identical+--     functions reproduces 'toMermaidWith' byte-for-byte.+data MermaidStateLabels s = MermaidStateLabels+  { stateId :: s -> Text,+    stateDisplayLabel :: s -> Text+  }++-- | Like 'toMermaidWith', but the caller supplies separate stable+-- identifiers and friendly display labels via 'MermaidStateLabels'+-- instead of deriving both from 'Show'. The @Show s@ constraint is+-- dropped — labels come from the callbacks.+--+-- For every vertex whose display label differs from its id, a+-- @state \"<display>\" as <id>@ declaration line is emitted between the+-- @stateDiagram-v2@ header and the initial-state line; every transition+-- arrow and @[*]@ marker uses the stable id. Vertices whose display+-- equals their id get no declaration. The default 'toMermaid' /+-- 'toMermaidWith' path is unaffected.+toMermaidWithLabels ::+  (Bounded s, Enum s) =>+  MermaidOptions ->+  MermaidStateLabels s ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  Text+toMermaidWithLabels opts lbls =+  renderTopologyWith opts (stateId lbls) (stateDisplayLabel lbls)++-- | Return the ASCII ids that collide: any id produced by 'stateId'+-- for two or more distinct vertices. An empty result means every vertex+-- maps to a unique id. Result order is first-occurrence order.+--+-- Rendering itself stays total (it never throws on a collision); this is+-- the AST-level check a caller runs before trusting a labeled diagram.+-- The sibling validation helpers in "Keiki.Render" detect the same+-- collisions over rendered diagram /text/ and key off the same id token,+-- so the two agree on what an \"id\" is by construction.+duplicateStateIds ::+  (Bounded s, Enum s) =>+  MermaidStateLabels s ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  [Text]+duplicateStateIds lbls _t =+  let ids = Prelude.map (stateId lbls) [minBound .. maxBound]+   in [i | i <- nubInOrder ids, count i ids > (1 :: Int)]+  where+    count x = length . filter (== x)+    nubInOrder =+      foldr (\x acc -> if x `elem` acc then acc else x : acc) []++-- | Render a composite 'SymTransducer' (a 'Keiki.Composition.compose'+-- result, vertex type @'Composite' s1 s2@) to a Mermaid+-- @stateDiagram-v2@ block.+--+-- Uses the **flat cross-product** shape: each composite vertex+-- @'Composite' a b@ becomes a single Mermaid identifier+-- @<show a>_<show b>@. The structure is otherwise identical to+-- 'toMermaid' — same initial / final / edge emission rules, same+-- 'edgeLabel' format. See EP-31's Decision Log+-- (@docs/plans/31-mermaid-rendering-for-composite-symtransducers.md@)+-- for why the flat shape was chosen over Mermaid's nested-subgraph+-- syntax (Shape B in the plan).+toMermaidComposite ::+  ( Enum s1,+    Bounded s1,+    Show s1,+    Enum s2,+    Bounded s2,+    Show s2+  ) =>+  SymTransducer (HsPred rs ci) rs (Composite s1 s2) ci co ->+  Text+toMermaidComposite = renderTopology compositeLabel++-- | Render a right-associative 3-deep+-- @t1 \`'Keiki.Composition.compose'\` (t2 \`'Keiki.Composition.compose'\` t3)@+-- composite (vertex type @'Composite' s1 ('Composite' s2 s3)@) to a+-- Mermaid @stateDiagram-v2@ block in the **flat cross-product** shape.+--+-- Each composite vertex becomes a single Mermaid identifier+-- @\<show s1\>_\<show s2\>_\<show s3\>@ via 'compose3Label'. The+-- structure is otherwise identical to 'toMermaid' /+-- 'toMermaidComposite' — same initial / final / edge emission rules,+-- same 'edgeLabel' format. See EP-35's plan+-- (@docs/plans/35-mermaid-renderer-for-right-associative-3-deep-compose-composites.md@)+-- for the rationale and for the comparison against the+-- nested-subgraph variant 'toMermaidCompose3Nested'.+toMermaidCompose3 ::+  forall rs s1 s2 s3 ci co.+  ( Enum s1,+    Bounded s1,+    Show s1,+    Enum s2,+    Bounded s2,+    Show s2,+    Enum s3,+    Bounded s3,+    Show s3+  ) =>+  SymTransducer+    (HsPred rs ci)+    rs+    (Composite s1 (Composite s2 s3))+    ci+    co ->+  Text+toMermaidCompose3 = renderTopology compose3Label++-- | Render a composite 'SymTransducer' (a 'Keiki.Composition.compose'+-- result, vertex type @'Composite' s1 s2@) using the **nested-subgraph**+-- shape (Shape B): each outer @s1@ vertex hosts a+-- @state \<show s1\> { \<inner ids\> }@ block listing every+-- @\<show s1\>_\<show s2\>@ identifier in the column. Cross-cutting+-- transitions remain at the top level using the same flat identifiers+-- 'compositeLabel' produces, so the renderer never relies on+-- Mermaid's @Outer.Inner@ dotted cross-block reference syntax.+--+-- Use this for composites where the cross-product becomes hard to+-- scan as a single line; use 'toMermaidComposite' for tiny composites+-- (1–4 vertices) where outer-state grouping adds visual overhead with+-- no payoff. Both shapes coexist; pick the one that reads best for+-- the composite at hand.+--+-- Note on edge organisation: 'Keiki.Composition.compose' composites+-- have **zero same-outer edges** — every composite edge advances the+-- outer @s1@ component (the composite-edge construction in+-- @Keiki.Composition.composedEdges@ either advances @s1@ on a t1+-- ε-edge or on the synchronised t1+t2 step, never leaves @s1@+-- fixed). The visual benefit of this layout for those composites is+-- structural grouping of vertices, not edge organisation. Composites+-- produced by @Keiki.Composition.alternative@ (which DOES yield+-- same-outer edges) are rendered by a separate+-- @toMermaidAlternative@ entry point — see+-- @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@.+--+-- See EP-32's plan+-- (@docs/plans/32-shape-b-nested-subgraph-mermaid-rendering-for-larger-composites.md@)+-- for the full rationale and the Mermaid-syntax cheatsheet.+toMermaidCompositeNested ::+  forall rs s1 s2 ci co.+  ( Enum s1,+    Bounded s1,+    Show s1,+    Enum s2,+    Bounded s2,+    Show s2+  ) =>+  SymTransducer (HsPred rs ci) rs (Composite s1 s2) ci co ->+  Text+toMermaidCompositeNested t =+  let outers = [minBound .. maxBound] :: [s1]+      inners = [minBound .. maxBound] :: [s2]+      composites = [minBound .. maxBound] :: [Composite s1 s2]++      ind = T.pack "    "+      ind2 = T.pack "        "+      arrow = T.pack " --> "+      colon = T.pack " : "++      header = T.pack "stateDiagram-v2"+      initLine =+        ind+          <> T.pack "[*]"+          <> arrow+          <> compositeLabel (initial t)++      outerBlock o =+        T.intercalate (T.pack "\n") $+          [ind <> T.pack "state " <> vertexLabel o <> T.pack " {"]+            ++ [ind2 <> compositeLabel (Composite o i) | i <- inners]+            ++ [ind <> T.pack "}"]++      outerBlocks = [outerBlock o | o <- outers]++      edgeLines =+        [ ind+            <> compositeLabel s+            <> arrow+            <> compositeLabel (target e)+            <> colon+            <> edgeLabel e+        | s <- composites,+          e <- edgesOut t s+        ]++      finalLines =+        [ ind <> compositeLabel s <> arrow <> T.pack "[*]"+        | s <- composites,+          isFinal t s+        ]+   in T.intercalate+        (T.pack "\n")+        (header : initLine : outerBlocks ++ edgeLines ++ finalLines)++-- | Render a right-associative 3-deep+-- @t1 \`'Keiki.Composition.compose'\` (t2 \`'Keiki.Composition.compose'\` t3)@+-- composite (vertex type @'Composite' s1 ('Composite' s2 s3)@) using+-- the **one-level nested-subgraph** shape: each outer @s1@ vertex+-- hosts a @state \<show s1\> { \<inner ids\> }@ block listing every+-- @\<show s1\>_\<show s2\>_\<show s3\>@ identifier under that outer.+-- Cross-cutting transitions remain at the top level using the same+-- flat identifiers 'compose3Label' produces, so the renderer never+-- relies on Mermaid's @Outer.Inner@ dotted cross-block reference+-- syntax (the EP-32 lesson, carried forward).+--+-- The nest is intentionally **one level deep**, not two: a two-level+-- nest @state s1 { state s2 { … } }@ would mirror @compose@'s+-- structural shape more faithfully but adds renderer-compat risk+-- (some Mermaid backends parse nested @state@ blocks+-- inconsistently). One-level groups composites by their outer+-- aggregate, which is the readability win the larger 3-deep+-- composites need; if a tighter grouping is later required for a+-- specific use case, a follow-up renderer can add the two-level+-- variant with explicit backend verification.+--+-- See EP-35's plan+-- (@docs/plans/35-mermaid-renderer-for-right-associative-3-deep-compose-composites.md@)+-- for the design record and for the flat counterpart+-- 'toMermaidCompose3'.+toMermaidCompose3Nested ::+  forall rs s1 s2 s3 ci co.+  ( Enum s1,+    Bounded s1,+    Show s1,+    Enum s2,+    Bounded s2,+    Show s2,+    Enum s3,+    Bounded s3,+    Show s3+  ) =>+  SymTransducer+    (HsPred rs ci)+    rs+    (Composite s1 (Composite s2 s3))+    ci+    co ->+  Text+toMermaidCompose3Nested t =+  let outers = [minBound .. maxBound] :: [s1]+      inners = [minBound .. maxBound] :: [Composite s2 s3]+      composites = [minBound .. maxBound] :: [Composite s1 (Composite s2 s3)]++      ind = T.pack "    "+      ind2 = T.pack "        "+      arrow = T.pack " --> "+      colon = T.pack " : "++      header = T.pack "stateDiagram-v2"+      initLine =+        ind+          <> T.pack "[*]"+          <> arrow+          <> compose3Label (initial t)++      outerBlock o =+        T.intercalate (T.pack "\n") $+          [ind <> T.pack "state " <> vertexLabel o <> T.pack " {"]+            ++ [ind2 <> compose3Label (Composite o i) | i <- inners]+            ++ [ind <> T.pack "}"]++      outerBlocks = [outerBlock o | o <- outers]++      edgeLines =+        [ ind+            <> compose3Label s+            <> arrow+            <> compose3Label (target e)+            <> colon+            <> edgeLabel e+        | s <- composites,+          e <- edgesOut t s+        ]++      finalLines =+        [ ind <> compose3Label s <> arrow <> T.pack "[*]"+        | s <- composites,+          isFinal t s+        ]+   in T.intercalate+        (T.pack "\n")+        (header : initLine : outerBlocks ++ edgeLines ++ finalLines)++-- | Render an 'Keiki.Composition.alternative'-shaped composite as+-- two parallel side-by-side state machines.+--+-- Each component transducer becomes its own+-- @state \<arm-name\> { \<topology\> }@ block listing that arm's edges;+-- both arms share top-level @[*] --> \<initial\>@ initial-state+-- markers and top-level @\<final\> --> [*]@ final-state markers, so+-- the parallel-start / parallel-finish semantics is visible at a+-- glance.+--+-- The runtime composite's vertex space is the cross-product+-- @'Composite' s1 s2@ — but the diagram presents the two arms as+-- independent machines because that mirrors the+-- 'Keiki.Composition.alternative' combinator's actual behaviour:+-- each Either-tagged input advances exactly one arm and leaves the+-- other untouched. The cross-product is implicit; the reader infers+-- "the system's actual state is the combination of both arms'+-- current states."+--+-- Default arm names are @LeftArm@ and @RightArm@. Use+-- 'toMermaidAlternativeWith' to override (e.g. for domain-specific+-- naming such as @EmailArm@ / @PingerArm@).+--+-- Edge labels are the standard @\<input ctor\> / \<output ctor\>@ format+-- ('edgeLabel'). Because 'Keiki.Composition' lifters preserve+-- @icName@ and @wcName@ verbatim, the label reads naturally even+-- though the runtime input is @'Left' …@ / @'Right' …@.+--+-- See @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@+-- for the full design record.+toMermaidAlternative ::+  ( Enum s1,+    Bounded s1,+    Show s1,+    Enum s2,+    Bounded s2,+    Show s2+  ) =>+  SymTransducer (HsPred rs1 ci1) rs1 s1 ci1 co1 ->+  SymTransducer (HsPred rs2 ci2) rs2 s2 ci2 co2 ->+  Text+toMermaidAlternative =+  toMermaidAlternativeWith (T.pack "LeftArm") (T.pack "RightArm")++-- | The arm-name-overridable variant of 'toMermaidAlternative'. The+-- two 'Text' arguments name the left and right @state … { … }@+-- blocks; pick names that match the user's domain vocabulary.+--+-- The names must be valid Mermaid identifiers+-- (regex @[A-Za-z_][A-Za-z0-9_]*@); the renderer does not validate+-- them.+toMermaidAlternativeWith ::+  forall rs1 rs2 s1 s2 ci1 ci2 co1 co2.+  ( Enum s1,+    Bounded s1,+    Show s1,+    Enum s2,+    Bounded s2,+    Show s2+  ) =>+  -- | Left arm's state-block name.+  Text ->+  -- | Right arm's state-block name.+  Text ->+  SymTransducer (HsPred rs1 ci1) rs1 s1 ci1 co1 ->+  SymTransducer (HsPred rs2 ci2) rs2 s2 ci2 co2 ->+  Text+toMermaidAlternativeWith leftName rightName t1 t2 =+  let ind = T.pack "    "+      ind2 = T.pack "        "+      arrow = T.pack " --> "+      colon = T.pack " : "++      header = T.pack "stateDiagram-v2"++      initLines =+        [ ind <> T.pack "[*]" <> arrow <> vertexLabel (initial t1),+          ind <> T.pack "[*]" <> arrow <> vertexLabel (initial t2)+        ]++      armBlock ::+        forall rs s ci co.+        (Enum s, Bounded s, Show s) =>+        Text ->+        SymTransducer (HsPred rs ci) rs s ci co ->+        Text+      armBlock name t =+        T.intercalate (T.pack "\n") $+          [ind <> T.pack "state " <> name <> T.pack " {"]+            ++ [ ind2+                   <> vertexLabel s+                   <> arrow+                   <> vertexLabel (target e)+                   <> colon+                   <> edgeLabel e+               | s <- [minBound .. maxBound],+                 e <- edgesOut t s+               ]+            ++ [ind <> T.pack "}"]++      finalLines ::+        forall rs s ci co.+        (Enum s, Bounded s, Show s) =>+        SymTransducer (HsPred rs ci) rs s ci co ->+        [Text]+      finalLines t =+        [ ind <> vertexLabel s <> arrow <> T.pack "[*]"+        | s <- [minBound .. maxBound],+          isFinal t s+        ]+   in T.intercalate (T.pack "\n") $+        [header]+          ++ initLines+          ++ [ armBlock leftName t1,+               armBlock rightName t2+             ]+          ++ finalLines t1+          ++ finalLines t2++-- | Render a 'Keiki.Composition.feedback1'-shaped composite as a+-- flat 3-deep cross-product diagram.+--+-- The composite's vertex type is+-- @'Composite' s1 ('Composite' s2 s1)@ — outer-t state, then policy+-- state, then inner-t state. Each composite vertex becomes a single+-- Mermaid identifier @\<show s1\>_\<show s2\>_\<show s1\>@. The two+-- copies of @t@ (outer and inner) share the same Haskell vertex+-- type but occupy distinct dimensions of the composite tuple, so+-- they are labelled independently.+--+-- For the cascade structure (@'feedback1' t f =+-- 'compose' t ('compose' f t)@), see @feedback1@'s haddock and the+-- design note at+-- @docs/research/composition-combinators-design.md@. The renderer+-- treats the resulting transducer as a flat enumerable cross-product;+-- it does not inspect the cascade structure beyond decomposing the+-- composite tuple for labelling.+toMermaidFeedback1 ::+  ( Enum s1,+    Bounded s1,+    Show s1,+    Enum s2,+    Bounded s2,+    Show s2,+    WeakenR rs1,+    WeakenR rs2,+    Disjoint (Names rs2) (Names rs1),+    Disjoint (Names rs1) (Names (Append rs2 rs1))+  ) =>+  SymTransducer (HsPred rs1 ci) rs1 s1 ci co ->+  SymTransducer (HsPred rs2 co) rs2 s2 co ci ->+  Text+toMermaidFeedback1 t f = renderTopology feedback1Label (feedback1 t f)++-- | The Mermaid identifier for a 'feedback1' composite vertex.+-- @\<show outer\>_\<show policy\>_\<show inner\>@. Like+-- 'compositeLabel', joined with underscores so the result still+-- matches Mermaid's identifier regex @[A-Za-z_][A-Za-z0-9_]*@.+feedback1Label ::+  (Show s1, Show s2) =>+  Composite s1 (Composite s2 s1) -> Text+feedback1Label (Composite a (Composite b c)) =+  T.pack (show a)+    <> T.pack "_"+    <> T.pack (show b)+    <> T.pack "_"+    <> T.pack (show c)++-- | The Mermaid identifier for a right-associative 3-deep+-- @'Composite' s1 ('Composite' s2 s3)@ vertex.+-- @\<show outer\>_\<show middle\>_\<show inner\>@ — joined with+-- underscores so the result still matches Mermaid's identifier regex+-- @[A-Za-z_][A-Za-z0-9_]*@. The default 'Show' for 'Composite' emits+-- @"Composite a (Composite b c)"@ with whitespace and parentheses, which+-- is not a legal Mermaid identifier; this label sidesteps that by+-- destructuring the composite tuple itself and joining the three+-- component shows directly.+--+-- Sibling of 'compositeLabel' (2-deep) and 'feedback1Label' (3-deep+-- with @s1@ recurring at the inner-inner position). 'compose3Label'+-- requires three independent 'Show' constraints because the three+-- component vertex types are unrelated.+compose3Label ::+  (Show s1, Show s2, Show s3) =>+  Composite s1 (Composite s2 s3) -> Text+compose3Label (Composite a (Composite b c)) =+  T.pack (show a)+    <> T.pack "_"+    <> T.pack (show b)+    <> T.pack "_"+    <> T.pack (show c)++-- | The shared rendering core: walk @[minBound .. maxBound]@, emit+-- the @stateDiagram-v2@ header, the initial-state line, one line per+-- outgoing edge, and one final-state line per vertex where+-- 'isFinal' fires. The vertex-label function is the only piece that+-- varies between 'toMermaid' (single transducer) and+-- 'toMermaidComposite' (composite); factoring it out keeps the+-- rendering logic in one place.+renderTopology ::+  (Enum s, Bounded s) =>+  (s -> Text) ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  Text+renderTopology label = renderTopologyWith defaultMermaidOptions label label++-- | The options-aware rendering core. Identical to 'renderTopology'+-- except the per-edge line calls 'edgeLabelWith' so the structural+-- summary suffix appears when 'MermaidOptions' requests it. With+-- 'defaultMermaidOptions' the output is byte-identical to the original+-- 'renderTopology', which is what keeps 'toMermaid' guard-free.+renderTopologyWith ::+  (Enum s, Bounded s) =>+  MermaidOptions ->+  -- | @idOf@: the stable Mermaid identifier for a vertex, used as+  --     the node id and in every transition arrow.+  (s -> Text) ->+  -- | @displayOf@: the visible display label for a vertex, which may+  --     contain spaces. When it differs from @idOf@ the renderer emits a+  --     @state \"<display>\" as <id>@ declaration line.+  (s -> Text) ->+  SymTransducer (HsPred rs ci) rs s ci co ->+  Text+renderTopologyWith opts idOf displayOf t =+  let vertices = [minBound .. maxBound]+      header = T.pack "stateDiagram-v2"+      ind = T.pack "    "+      arrow = T.pack " --> "+      colon = T.pack " : "+      -- A declaration is emitted ONLY when the display differs from+      -- the id; when they are equal (the Show-based default) this list+      -- is empty, so the default output stays byte-identical.+      declLines =+        [ ind <> T.pack "state \"" <> displayOf s <> T.pack "\" as " <> idOf s+        | s <- vertices,+          displayOf s /= idOf s+        ]+      initLine = ind <> T.pack "[*]" <> arrow <> idOf (initial t)+      edgeLines =+        [ ind+            <> idOf s+            <> arrow+            <> idOf (target e)+            <> colon+            <> edgeLabelWith opts e+        | s <- vertices,+          e <- edgesOut t s+        ]+      finalLines =+        [ ind <> idOf s <> arrow <> T.pack "[*]"+        | s <- vertices,+          isFinal t s+        ]+   in T.intercalate+        (T.pack "\n")+        (header : declLines ++ initLine : edgeLines ++ finalLines)++-- | The Mermaid identifier for a vertex. @'T.pack' . 'show'@ — for+-- every shipped aggregate's vertex type, the data-constructor names+-- already obey Mermaid's identifier regex+-- @[A-Za-z_][A-Za-z0-9_]*@.+vertexLabel :: (Show s) => s -> Text+vertexLabel = T.pack . show++-- | The Mermaid identifier for a composite vertex.+-- @'show' a \<\> "_" \<\> 'show' b@ — joined with an underscore so the+-- result still matches Mermaid's identifier regex+-- @[A-Za-z_][A-Za-z0-9_]*@. (The default 'Show' for 'Composite' emits+-- @"Composite a b"@ with spaces, which is not a legal Mermaid+-- identifier.)+compositeLabel :: (Show s1, Show s2) => Composite s1 s2 -> Text+compositeLabel (Composite a b) =+  T.pack (show a) <> T.pack "_" <> T.pack (show b)++-- | Extract the input-constructor name from an edge's guard, walking+-- the 'HsPred' AST for the leftmost 'PInCtor' atom. Returns 'Nothing'+-- if the guard contains no 'PInCtor'.+--+-- Every edge introduced via @"Keiki.Builder".'Keiki.Builder.onCmd'@+-- has a recoverable input-constructor name because the builder wraps+-- each guard in @'PAnd' ('PInCtor' ic) inner@. Hand-written AST edges+-- that omit 'PInCtor' produce 'Nothing'; 'edgeLabel' substitutes+-- @"?"@ in that case.+edgeInputName :: Edge (HsPred rs ci) rs ci co s -> Maybe Text+edgeInputName Edge {guard = g} = walk g+  where+    walk :: HsPred rs ci -> Maybe Text+    walk (PInCtor InCtor {icName = n}) = Just (T.pack n)+    walk (PAnd a b) = walk a <|> walk b+    walk (POr a b) = walk a <|> walk b+    walk (PNot p) = walk p+    walk PTop = Nothing+    walk PBot = Nothing+    walk (PEq _ _) = Nothing+    walk (PCmp {}) = Nothing++-- | Extract the output-constructor name(s) from an edge's output+-- list. Returns 'Nothing' for an ε-edge (an edge whose 'output' is+-- @[]@); 'Just' a length-1/2/N rendering otherwise.+--+-- Per EP-19's design note, the rendering uses a length-based+-- switchover:+--+--   * length 1: @e1@                       — same as the letter case.+--   * length 2: @e1; e2@                   — compact inline separator.+--   * length 3+: @e1\<br/>e2\<br/>…\<br/>eN@ — Mermaid multi-line.+edgeOutputName :: Edge (HsPred rs ci) rs ci co s -> Maybe Text+edgeOutputName = edgeOutputNameWith MermaidOutputSemicolon++-- | The layout-aware output renderer behind 'edgeOutputName'. Returns+-- 'Nothing' for an ε-edge (output @[]@) under every layout, and the lone+-- constructor name for a single-event edge under every layout. For two or+-- more events the chosen 'MermaidOutputLayout' decides the rendering:+--+--   * 'MermaidOutputSemicolon' reproduces 'edgeOutputName''s historical+--     length-based behaviour — @;@ for exactly two, @<br/>@ for three or+--     more.+--   * 'MermaidOutputMultiline' always joins with @<br/>@.+--   * 'MermaidOutputCounted' collapses to @N events@.+--+-- Output order is the transducer's 'output' list order, preserved+-- verbatim.+edgeOutputNameWith ::+  MermaidOutputLayout ->+  Edge (HsPred rs ci) rs ci co s ->+  Maybe Text+edgeOutputNameWith layout Edge {output = outs} = case outs of+  [] -> Nothing+  [o] -> Just (wcN o)+  many -> Just (render layout (Prelude.map wcN many))+  where+    wcN :: OutTerm rs ci co -> Text+    wcN (OPack _ wc _) = T.pack (wcName wc)+    render :: MermaidOutputLayout -> [Text] -> Text+    render MermaidOutputSemicolon ns+      | length ns == 2 = T.intercalate (T.pack "; ") ns+      | otherwise = T.intercalate (T.pack "<br/>") ns+    render MermaidOutputMultiline ns = T.intercalate (T.pack "<br/>") ns+    render MermaidOutputCounted ns = T.pack (show (length ns) <> " events")++-- | The Mermaid edge label for an edge: @<input ctor> / <output ctor>@.+-- A missing input-constructor name (no 'PInCtor' in the guard)+-- becomes @"?"@; a missing output (an ε-edge) becomes @"ε"@. Uses the+-- default 'MermaidOutputSemicolon' output layout, so its behaviour is+-- unchanged from before EP-63.+edgeLabel :: Edge (HsPred rs ci) rs ci co s -> Text+edgeLabel = edgeLabelWithLayout MermaidOutputSemicolon++-- | The output-layout-aware base label behind 'edgeLabel'. Renders+-- @<input ctor> / <output ctor>@ using the supplied 'MermaidOutputLayout'+-- for the output half; 'edgeLabel' delegates to it with+-- 'MermaidOutputSemicolon'.+edgeLabelWithLayout ::+  MermaidOutputLayout ->+  Edge (HsPred rs ci) rs ci co s ->+  Text+edgeLabelWithLayout layout e =+  let inp = maybe (T.pack "?") id (edgeInputName e)+      out = maybe (T.pack "\x03B5") id (edgeOutputNameWith layout e)+   in inp <> T.pack " / " <> out++-- | The options-aware edge label: 'edgeLabel' plus an optional+-- structural suffix @[w: …; g: …]@. When neither flag is set this is+-- exactly 'edgeLabel' (no trailing space, no brackets), which is what+-- keeps the 'toMermaid' default byte-identical. The written-slots part+-- is omitted entirely when the edge writes nothing (an empty @w:@ would+-- be noise); the guard part renders the full structural tag walk.+edgeLabelWith ::+  MermaidOptions ->+  Edge (HsPred rs ci) rs ci co s ->+  Text+edgeLabelWith opts e@Edge {update = u, guard = g} =+  -- The whole edge @e@ is reused for the base label; @u@ and @g@ are+  -- bound by the pattern so the existential write-set in @update@ does+  -- not escape (the record selector cannot be used as a function for+  -- it). This function owns only segment /layout/ and /truncation/ and+  -- the output rendering; guard /text/ is produced by+  -- 'renderGuardSegment' (EP-61's chokepoint).+  let base = edgeLabelWithLayout (outputLayout opts) e+      ws = if showWrittenSlots opts then writtenSlots u else []+      wPart =+        case truncateSlots (maxInlineWrittenSlots opts) ws of+          [] -> []+          xs -> [T.pack "w: " <> T.intercalate (T.pack "; ") xs]+      gPart = case renderGuardSegment opts g of+        Just t -> [T.pack "g: " <> truncateGuard (maxInlineGuardWidth opts) t]+        Nothing -> []+      parts = wPart ++ gPart+   in case labelLayout opts of+        MermaidLabelInline ->+          if null parts+            then base+            else base <> T.pack " [" <> T.intercalate (T.pack "; ") parts <> T.pack "]"+        MermaidLabelMultiline ->+          T.intercalate (T.pack "<br/>") (base : parts)++-- | Keep the first @k@ slots, replacing the rest with a single+-- @+{n-k} more@ token. 'Nothing' or @n <= k@ leaves the list unchanged.+-- Slot order is preserved.+truncateSlots :: Maybe Int -> [Text] -> [Text]+truncateSlots Nothing xs = xs+truncateSlots (Just k) xs+  | length xs > k =+      take k xs ++ [T.pack ("+" <> show (length xs - k) <> " more")]+  | otherwise = xs++-- | Truncate guard segment text to @w@ characters, appending the+-- ellipsis @…@ (U+2026) when it was longer. 'Nothing' or a text already+-- within @w@ characters is returned unchanged.+truncateGuard :: Maybe Int -> Text -> Text+truncateGuard Nothing t = t+truncateGuard (Just w) t+  | T.length t > w = T.take w t <> T.pack "\x2026"+  | otherwise = t++-- | Recover the names of the slots an edge's 'Update' writes, by+-- structural recursion over the 'Update' value. 'USet's @KnownSymbol s@+-- constraint (brought into scope by the pattern match) lets+-- 'indexNName' read the slot name off the index; no type-level+-- write-set machinery is needed.+writtenSlots :: Update rs w ci -> [Text]+writtenSlots UKeep = []+writtenSlots (USet ix _) = [T.pack (indexNName ix)]+writtenSlots (UCombine a b) = writtenSlots a ++ writtenSlots b++-- | Produce the guard segment text for an edge, or 'Nothing' when no+-- guard segment should appear. The effective mode reconciles the legacy+-- 'showGuardSummary' flag with the new 'guardMode': an explicit+-- 'guardMode' (anything other than 'MermaidGuardHidden') wins; otherwise+-- 'showGuardSummary' is honoured as the legacy spelling of+-- 'MermaidGuardStructuralSummary'.+--+-- This is the single chokepoint for guard /text/ production. A sibling+-- renderer that changes how edge-label /segments are laid out/ (inline+-- vs. multiline) wraps the assembly of segments and leaves this+-- function's text untouched.+renderGuardSegment :: MermaidOptions -> HsPred rs ci -> Maybe Text+renderGuardSegment opts g =+  case effectiveMode of+    MermaidGuardHidden -> Nothing+    MermaidGuardStructuralSummary -> Just (guardSummary g)+    MermaidGuardPretty -> Just (prettyPred g)+  where+    effectiveMode+      | guardMode opts /= MermaidGuardHidden = guardMode opts+      | showGuardSummary opts = MermaidGuardStructuralSummary+      | otherwise = MermaidGuardHidden++-- | A structural, total summary of a guard predicate: its constructor+-- tags in left-to-right (prefix) order, with 'PCmp' carrying its 'Cmp'+-- direction. It deliberately does NOT print the operand 'Term's — those+-- can hold opaque Haskell functions ('TApp1'\/'TApp2'), and the+-- input-constructor inside 'PInCtor' carries unprintable match\/build+-- functions. This is the faithful renderable projection of an otherwise+-- unprintable AST.+guardSummary :: HsPred rs ci -> Text+guardSummary = T.intercalate (T.pack " ") . go+  where+    go :: HsPred rs ci -> [Text]+    go PTop = [T.pack "PTop"]+    go PBot = [T.pack "PBot"]+    go (PAnd a b) = T.pack "PAnd" : go a ++ go b+    go (POr a b) = T.pack "POr" : go a ++ go b+    go (PNot p) = T.pack "PNot" : go p+    go (PEq _ _) = [T.pack "PEq"]+    go (PInCtor _) = [T.pack "PInCtor"]+    go (PCmp c _ _) = [T.pack "PCmp " <> T.pack (show c)]++-- | Assemble several already-rendered Mermaid diagrams into one+-- document, each under a labelled section. Each input pair is+-- @(sectionLabel, renderedDiagram)@ where @renderedDiagram@ is the+-- 'Text' produced by any single-transducer or composite renderer in+-- this module (e.g. 'toMermaid', 'toMermaidComposite'). The label is+-- emitted as a Markdown level-2 heading; the diagram is emitted inside+-- a fenced @mermaid@ code block so it renders inline in GitHub \/+-- Notion \/ Markdown previewers.+--+-- Transducers are heterogeneously typed (each has its own vertex,+-- register, input and output types), so a single list of transducers+-- would not type-check; taking already-rendered 'Text' lets each caller+-- pick the matching renderer for its own transducer. An empty list+-- yields the empty 'Text'.+toMermaidAtlas :: [(Text, Text)] -> Text+toMermaidAtlas sections =+  toMermaidAtlasWith+    defaultMermaidAtlasOptions+    [ MermaidSection+        { sectionId = T.pack ("section-" <> show i),+          sectionTitle = title,+          sectionKind = CustomDiagram (T.pack ""),+          sectionDiagram = diagram+        }+    | (i, (title, diagram)) <- zip [(0 :: Int) ..] sections+    ]++-- | What kind of transducer a diagram section depicts. Lets a generated+-- atlas distinguish an aggregate state diagram from a process-manager or+-- workflow diagram. 'CustomDiagram' carries a caller-chosen label for+-- anything outside the three named kinds.+data MermaidSectionKind+  = AggregateDiagram+  | ProcessManagerDiagram+  | WorkflowDiagram+  | CustomDiagram Text+  deriving stock (Eq, Show)++-- | One section of a diagram atlas. 'sectionDiagram' is already-rendered+-- Mermaid 'Text' (produced by 'toMermaid' \/ 'toMermaidWith' or any other+-- renderer in this module), so the atlas is independent of the+-- transducer's vertex\/register\/input\/output types. 'sectionId' is a+-- stable token suitable for use as a Markdown replacement-marker id (see+-- "Keiki.Render.Markdown").+data MermaidSection = MermaidSection+  { sectionId :: Text,+    sectionTitle :: Text,+    sectionKind :: MermaidSectionKind,+    sectionDiagram :: Text+  }+  deriving stock (Eq, Show)++-- | How (or whether) to surface a section's 'MermaidSectionKind' in the+-- rendered atlas.+data AtlasKindDisplay+  = -- | Do not render the kind at all (default).+    KindHidden+  | -- | Render the kind as a visible italic line under the heading.+    KindAsLabel+  | -- | Render the kind as an HTML comment (invisible in previews).+    KindAsComment+  deriving stock (Eq, Show)++-- | Options for 'toMermaidAtlasWith'. Every field defaults (in+-- 'defaultMermaidAtlasOptions') to a value that reproduces the legacy+-- 'toMermaidAtlas' output byte-for-byte.+data MermaidAtlasOptions = MermaidAtlasOptions+  { -- | Optional top-level heading prepended above all sections. Default 'Nothing'.+    atlasTitle :: Maybe Text,+    -- | Markdown heading level for each section heading. Default 2 (@## @).+    atlasSectionHeadingLevel :: Int,+    -- | Whether\/how to show each section's kind. Default 'KindHidden'.+    atlasShowSectionKind :: AtlasKindDisplay,+    -- | When @'Just' ns@, wrap each section's fenced block in+    --     @\<!-- ns: sectionId begin --\>@ \/ @\<!-- ns: sectionId end --\>@+    --     markers, so 'Keiki.Render.Markdown.replaceMarkdownDiagramBlock' can+    --     later update that block in place. Default 'Nothing'.+    atlasWrapMarkers :: Maybe Text,+    -- | Fenced-block language tag. Default @"mermaid"@.+    atlasFenceLanguage :: Text+  }++-- | The default atlas options: no top-level title, heading level 2,+-- hidden kind, no markers, @mermaid@ fence. @'toMermaidAtlasWith'+-- 'defaultMermaidAtlasOptions'@ over sections built from @(title, diagram)@+-- pairs is byte-identical to the legacy 'toMermaidAtlas'.+defaultMermaidAtlasOptions :: MermaidAtlasOptions+defaultMermaidAtlasOptions =+  MermaidAtlasOptions+    { atlasTitle = Nothing,+      atlasSectionHeadingLevel = 2,+      atlasShowSectionKind = KindHidden,+      atlasWrapMarkers = Nothing,+      atlasFenceLanguage = T.pack "mermaid"+    }++-- | Assemble typed diagram sections into one Markdown document. With+-- 'defaultMermaidAtlasOptions' the per-section output is+-- @## {title}\\n\\n```{lang}\\n{diagram}\\n```@ and sections are joined by a+-- blank line, byte-identical to the legacy 'toMermaidAtlas'. Turning on a+-- field adds output (a top-level title, a per-section kind line, or+-- begin/end markers keyed by 'sectionId') without disturbing the rest.+toMermaidAtlasWith :: MermaidAtlasOptions -> [MermaidSection] -> Text+toMermaidAtlasWith opts secs =+  let body = T.intercalate (T.pack "\n\n") (map (renderSection opts) secs)+   in case atlasTitle opts of+        Nothing -> body+        Just t+          | T.null body -> T.pack "# " <> t+          | otherwise -> T.pack "# " <> t <> T.pack "\n\n" <> body++-- | Render one atlas section: a heading, an optional kind line, and the+-- fenced diagram block (optionally wrapped in begin/end markers). The+-- within-section pieces are joined by a blank line.+renderSection :: MermaidAtlasOptions -> MermaidSection -> Text+renderSection opts sec =+  let heading =+        T.replicate (atlasSectionHeadingLevel opts) (T.pack "#")+          <> T.pack " "+          <> sectionTitle sec+      kindLine = case atlasShowSectionKind opts of+        KindHidden -> Nothing+        KindAsLabel -> Just (T.pack "_" <> kindText (sectionKind sec) <> T.pack "_")+        KindAsComment -> Just (T.pack "<!-- kind: " <> kindText (sectionKind sec) <> T.pack " -->")+      fenced =+        T.pack "```"+          <> atlasFenceLanguage opts+          <> T.pack "\n"+          <> sectionDiagram sec+          <> T.pack "\n```"+      block = case atlasWrapMarkers opts of+        Nothing -> fenced+        Just ns ->+          T.pack "<!-- "+            <> ns+            <> T.pack ": "+            <> sectionId sec+            <> T.pack " begin -->\n"+            <> fenced+            <> T.pack "\n<!-- "+            <> ns+            <> T.pack ": "+            <> sectionId sec+            <> T.pack " end -->"+   in T.intercalate (T.pack "\n\n") (heading : maybe id (:) kindLine [block])++-- | The visible label for a 'MermaidSectionKind', used by+-- 'renderSection' when 'atlasShowSectionKind' is not 'KindHidden'.+kindText :: MermaidSectionKind -> Text+kindText AggregateDiagram = T.pack "Aggregate"+kindText ProcessManagerDiagram = T.pack "Process manager"+kindText WorkflowDiagram = T.pack "Workflow"+kindText (CustomDiagram lbl) = lbl
+ src/Keiki/Render/Pretty.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TypeAbstractions #-}++-- | Pure, domain-readable pretty-printer for keiki's predicate, term,+-- and update syntax trees ('HsPred', 'Term', 'Update'). Produces+-- 'Data.Text.Text'. No solver, no IO. Shared by the Mermaid topology+-- renderer ('Keiki.Render.Mermaid') and the sibling edge-inspector /+-- multiline-label renderers.+--+-- Two things are provably unprintable and are marked, not dropped:+-- applied opaque Haskell functions render as @<fn>(...)@; literal+-- values render as @<lit>@ (a 'TLit' carries an unconstrained type+-- with no 'Show').+module Keiki.Render.Pretty+  ( indexName,+    prettyTerm,+    prettyPred,+    prettyUpdate,+  )+where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as T+import GHC.TypeLits (symbolVal)+import Keiki.Core+  ( Cmp (..),+    HsPred (..),+    InCtor (..),+    Index (..),+    NumOp (..),+    Term (..),+    Update (..),+  )+import Keiki.Internal.Slots (indexNName)++-- | Recover the slot name an 'Index' points at, by walking 'SIdx' down+-- to the 'ZIdx' and reading its 'KnownSymbol'. No extra class+-- constraint is needed: 'ZIdx' carries the slot's symbol. The @ZIdx \@s@+-- type-application pattern binds the existential symbol directly.+indexName :: Index rs r -> String+indexName (ZIdx @s) = symbolVal (Proxy @s)+indexName (SIdx i) = indexName i++-- | Render a 'Term' as domain-readable 'Text'. Register reads render by+-- slot name, input-field reads as @ctor.field@, arithmetic structurally+-- with @+ - *@. Opaque applied functions render @<fn>(...)@; literal+-- values render @<lit>@ (a 'TLit' carries an unconstrained type with no+-- 'Show').+prettyTerm :: Term rs ci ifs r -> Text+prettyTerm (TLit _) = T.pack "<lit>"+prettyTerm (TReg ix) = T.pack (indexName ix)+prettyTerm (TInpCtorField ic ix) =+  T.pack (icName ic) <> T.pack "." <> T.pack (indexName ix)+prettyTerm (TApp1 _ a) = T.pack "<fn>(" <> prettyTerm a <> T.pack ")"+prettyTerm (TApp2 _ a b) =+  T.pack "<fn>(" <> prettyTerm a <> T.pack ", " <> prettyTerm b <> T.pack ")"+prettyTerm (TArith op a b) =+  T.pack "("+    <> prettyTerm a+    <> T.pack " "+    <> numOpSym op+    <> T.pack " "+    <> prettyTerm b+    <> T.pack ")"+  where+    numOpSym OpAdd = T.pack "+"+    numOpSym OpSub = T.pack "-"+    numOpSym OpMul = T.pack "*"++-- | Render an 'HsPred' guard as domain-readable 'Text'. Boolean+-- structure renders with @&& || !@ and parentheses; @PInCtor@ renders+-- the constructor name; @PEq@/@PCmp@ render their operand 'Term's around+-- @== < <= > >=@.+prettyPred :: HsPred rs ci -> Text+prettyPred PTop = T.pack "true"+prettyPred PBot = T.pack "false"+prettyPred (PAnd a b) =+  T.pack "(" <> prettyPred a <> T.pack " && " <> prettyPred b <> T.pack ")"+prettyPred (POr a b) =+  T.pack "(" <> prettyPred a <> T.pack " || " <> prettyPred b <> T.pack ")"+prettyPred (PNot p) = T.pack "!(" <> prettyPred p <> T.pack ")"+prettyPred (PEq l r) = prettyTerm l <> T.pack " == " <> prettyTerm r+prettyPred (PInCtor ic) = T.pack (icName ic)+prettyPred (PCmp c l r) =+  prettyTerm l <> T.pack " " <> cmpSym c <> T.pack " " <> prettyTerm r+  where+    cmpSym CmpLt = T.pack "<"+    cmpSym CmpLe = T.pack "<="+    cmpSym CmpGt = T.pack ">"+    cmpSym CmpGe = T.pack ">="++-- | Render an 'Update' as domain-readable 'Text'. @UKeep@ renders+-- @(keep)@; @USet@ renders @slot := term@ (the slot name comes from the+-- name-tagged 'IndexN' via 'indexNName'); @UCombine@ joins comma-separated.+prettyUpdate :: Update rs w ci -> Text+prettyUpdate UKeep = T.pack "(keep)"+prettyUpdate (USet ix t) = T.pack (indexNName ix) <> T.pack " := " <> prettyTerm t+prettyUpdate (UCombine a b) = prettyUpdate a <> T.pack ", " <> prettyUpdate b
+ src/Keiki/Render/Validate.hs view
@@ -0,0 +1,203 @@+-- | Pure, cheap structural-heuristic validators for rendered keiki+-- Mermaid diagrams and Mermaid atlas documents.+--+-- These are __not__ a Mermaid parser. They scan rendered 'Text' for a small+-- set of common problems and return a deterministic, document-ordered list+-- of structured warnings. An empty list means \"no problems detected\" —+-- never \"guaranteed valid Mermaid\". The checks can miss problems Mermaid+-- would reject (false negatives) and can flag text Mermaid accepts (false+-- positives); they exist so a downstream unit test can catch the common,+-- cheap-to-detect mistakes before a rendered document is committed.+--+-- Mirrors the pure list-of-warnings house style of+-- 'Keiki.Core.validateTransducer' (EP-56), but operates on rendered 'Text'+-- rather than a 'Keiki.Core.SymTransducer', so there is no shared code.+--+-- See @docs/plans/66-pure-mermaid-diagram-and-atlas-validation-helpers.md@.+module Keiki.Render.Validate+  ( MermaidValidationOptions (..),+    defaultMermaidValidationOptions,+    MermaidValidationWarning (..),+    validateMermaidDiagram,+    validateMermaidAtlas,+  )+where++import Data.List (foldl')+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T++-- | Tunable knobs for the heuristic checks. The denylist and the label+-- budget are caller-tunable so a downstream test can match its own house+-- rules.+data MermaidValidationOptions = MermaidValidationOptions+  { -- | If @'Just' n@, a transition label longer than @n@ characters+    --     yields 'LabelTooLong'. 'Nothing' disables the length check.+    maxLabelLength :: Maybe Int,+    -- | Whether to run the suspicious-unescaped-character check at all.+    checkSuspiciousChars :: Bool,+    -- | The denylist of characters that commonly break Mermaid labels.+    --     The literal substring @\"<br/>\"@ is always exempt from this check+    --     regardless of what this set contains, because keiki emits @<br/>@+    --     deliberately for multi-event and multiline labels.+    suspiciousChars :: [Char]+  }+  deriving stock (Eq, Show)++-- | Sensible defaults: an 80-character label budget, suspicious-char+-- checking on, and the curated denylist @{ '"', '<', '>', '|', '{', '}' }@.+defaultMermaidValidationOptions :: MermaidValidationOptions+defaultMermaidValidationOptions =+  MermaidValidationOptions+    { maxLabelLength = Just 80,+      checkSuspiciousChars = True,+      suspiciousChars = ['"', '<', '>', '|', '{', '}']+    }++-- | One detected problem. Every constructor carries enough context to act+-- on the warning. Line numbers are 1-based, counted in the diagram text+-- handed to 'validateMermaidDiagram'.+data MermaidValidationWarning+  = -- | The first non-blank line is not (and does not start with) @stateDiagram-v2@.+    MissingStateDiagramHeader+  | -- | The document has a header but no transition, declaration, or grouping line under it.+    EmptyDiagram+  | -- | A transition label exceeds 'maxLabelLength'.+    LabelTooLong {warnLine :: Int, warnLength :: Int, warnLabel :: Text}+  | -- | The same @state \"…\" as \<id\>@ identifier is declared more than once, or with conflicting display labels.+    DuplicateStateId {warnStateId :: Text}+  | -- | A transition label contains a denylisted character.+    SuspiciousUnescapedChar {warnLine :: Int, warnChar :: Char, warnLabel :: Text}+  deriving stock (Eq, Show)++-- | Validate a single rendered diagram's 'Text'. Returns warnings in+-- document order: the header check, then the empty-diagram check, then the+-- per-transition-line label checks in line order, then the duplicate-id+-- warnings in first-declaration order. An empty result means no problem was+-- detected (not a guarantee of Mermaid validity — see the module header).+validateMermaidDiagram ::+  MermaidValidationOptions -> Text -> [MermaidValidationWarning]+validateMermaidDiagram opts diagram =+  let numbered = zip [1 :: Int ..] (T.lines diagram)+      contentLns = [(n, T.strip l) | (n, l) <- numbered, not (T.null (T.strip l))]+      headerWs = case contentLns of+        [] -> [MissingStateDiagramHeader]+        ((_, h) : _) ->+          [ MissingStateDiagramHeader+          | not (h == "stateDiagram-v2" || "stateDiagram-v2 " `T.isPrefixOf` h)+          ]+      bodyLns = drop 1 contentLns+      hasBody = any (\(_, l) -> isTransition l || isDecl l || isGroup l) bodyLns+      emptyWs = [EmptyDiagram | not (null contentLns) && not hasBody]+      labelWs =+        concatMap+          (\(n, l) -> labelWarnings opts n l)+          [ (n, l)+          | (n, l) <- numbered,+            isTransition (T.strip l),+            T.strip (transitionTarget l) /= "[*]"+          ]+      dupWs = duplicateStateIdWarnings [T.strip l | (_, l) <- numbered]+   in headerWs ++ emptyWs ++ labelWs ++ dupWs+  where+    isTransition l = " --> " `T.isInfixOf` l+    isDecl l = "state \"" `T.isInfixOf` l && " as " `T.isInfixOf` l+    isGroup l = "state " `T.isPrefixOf` l && "{" `T.isSuffixOf` l++-- | The target token of a transition line (between @ --> @ and @ : @, or+-- to end of line for a final marker). Used only to skip @--> [*]@ finals,+-- which carry no label.+transitionTarget :: Text -> Text+transitionTarget l =+  case T.breakOn " --> " l of+    (_, rest)+      | not (T.null rest) ->+          T.takeWhile (/= ':') (T.drop (T.length " --> ") rest)+    _ -> ""++-- | Per-transition-line label checks (length + suspicious chars).+labelWarnings ::+  MermaidValidationOptions -> Int -> Text -> [MermaidValidationWarning]+labelWarnings opts n line =+  case extractLabel line of+    Nothing -> []+    Just label ->+      let lenWs = case maxLabelLength opts of+            Just maxN+              | T.length label > maxN ->+                  [LabelTooLong {warnLine = n, warnLength = T.length label, warnLabel = label}]+            _ -> []+          charWs+            | checkSuspiciousChars opts =+                [ SuspiciousUnescapedChar {warnLine = n, warnChar = c, warnLabel = label}+                | c <- T.unpack (stripBrTags label),+                  c `elem` suspiciousChars opts+                ]+            | otherwise = []+       in lenWs ++ charWs++-- | The label of a transition line: the text after the first @ : @,+-- trimmed. 'Nothing' when the line has no @ : @ (e.g. a final marker).+extractLabel :: Text -> Maybe Text+extractLabel line =+  case T.breakOn " : " line of+    (_, rest) | not (T.null rest) -> Just (T.strip (T.drop 3 rest))+    _ -> Nothing++-- | Blank out @<br/>@ so its angle brackets are not flagged as suspicious.+stripBrTags :: Text -> Text+stripBrTags = T.replace "<br/>" " "++-- | Collect @state \"\<display\>\" as \<id\>@ declarations and report any+-- id declared twice or with conflicting display labels. Ids that merely+-- recur as transition endpoints are never reported (that is normal, and+-- keys off exactly the declaration lines EP-64's 'toMermaidWithLabels'+-- emits). Reported in first-declared (sorted-key) order.+duplicateStateIdWarnings :: [Text] -> [MermaidValidationWarning]+duplicateStateIdWarnings ls =+  let decls = [d | Just d <- map parseDecl ls]+      tally = foldl' (\m (i, disp) -> Map.insertWith (++) i [disp] m) Map.empty decls+   in [ DuplicateStateId {warnStateId = i}+      | (i, disps) <- Map.toList tally,+        length disps > 1 || length (nubText disps) > 1+      ]+  where+    nubText = foldr (\x acc -> if x `elem` acc then acc else x : acc) []++-- | Parse a @state \"\<display\>\" as \<id\>@ declaration line into its+-- @(id, display)@ pair; 'Nothing' for any other line.+parseDecl :: Text -> Maybe (Text, Text)+parseDecl l0 =+  case T.stripPrefix "state \"" (T.strip l0) of+    Nothing -> Nothing+    Just rest ->+      case T.breakOn "\" as " rest of+        (disp, afterDisp)+          | not (T.null afterDisp) ->+              Just (T.strip (T.drop (T.length "\" as ") afterDisp), disp)+        _ -> Nothing++-- | Validate a multi-section atlas: split into fenced @```mermaid@ blocks+-- and run 'validateMermaidDiagram' on each, aggregating warnings in block+-- order.+validateMermaidAtlas ::+  MermaidValidationOptions -> Text -> [MermaidValidationWarning]+validateMermaidAtlas opts doc =+  concatMap (validateMermaidDiagram opts) (mermaidBlocks (T.lines doc))++-- | Extract the inner text of each @```mermaid@ … @```@ fenced block: the+-- lines strictly between an opening fence line whose trimmed content is+-- exactly @```mermaid@ and the next line whose trimmed content is exactly+-- @```@.+mermaidBlocks :: [Text] -> [Text]+mermaidBlocks = go+  where+    go [] = []+    go (l : rest)+      | T.strip l == "```mermaid" =+          let (body, after) = break (\x -> T.strip x == "```") rest+           in T.intercalate "\n" body : go (dropOne after)+      | otherwise = go rest+    dropOne (_ : xs) = xs+    dropOne [] = []
+ src/Keiki/Shape.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE DefaultSignatures #-}++-- | The /shape hash/ for @RegFile rs@.+--+-- A snapshot persister (see keiro's @StateCodec (s, RegFile rs)@) needs a+-- compact, GHC-upgrade-safe discriminator for the type-level slot list.+-- 'regFileShapeHash' provides it: a SHA-256 of a canonical, deterministic+-- rendering of every slot's name and type.+--+-- The hash is sensitive to structural changes (slot rename / addition /+-- removal / reordering / type change) and insensitive to incidental+-- changes (GHC patch version, cabal dependency tree, the slot type's+-- typeclass instances). See @docs\/plans\/36-regfile-json-codec-and-shape-hash-for-snapshot-persistence.md@+-- §3 R3–R5 for the contract and §4 for the schema-evolution cases the+-- hash catches.+--+-- This module is the keiki-side primitive. The JSON codec lives in the+-- sibling package @keiki-codec-json@. Together they are the two halves+-- of the snapshot story: the hash discriminates eligible snapshots; the+-- codec serialises the eligible ones.+module Keiki.Shape+  ( -- * Shape hash+    KnownRegFileShape (..),+    regFileShapeHash,++    -- * Per-type canonical name (escape hatch)+    CanonicalTypeName (..),++    -- * TypeRep rendering+    renderStableTypeRep,++    -- * SHA-256 helper+    sha256Hex,+  )+where++import Crypto.Hash.SHA256 qualified as SHA256+import Data.Bits (shiftR, (.&.))+import Data.ByteString qualified as BS+import Data.Char (intToDigit)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Time.Calendar (Day)+import Data.Time.Clock (UTCTime)+import Data.Typeable (Typeable)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Keiki.Core (Slot)+import Type.Reflection+  ( SomeTypeRep (..),+    TypeRep,+    someTypeRep,+    splitApps,+    tyConModule,+    tyConName,+  )++-- * Canonical type names ----------------------------------------------------++-- | Stable, human-readable name for a slot type. The default+-- implementation uses 'renderStableTypeRep' on the type's 'Typeable'+-- runtime representation; users with stability concerns (a slot type+-- whose defining module is likely to be renamed, or a slot type that+-- straddles libraries with unstable module layouts) can override and+-- pin the name explicitly.+--+-- See P9 in EP-36 (@docs\/plans\/36-regfile-json-codec-and-shape-hash-for-snapshot-persistence.md@).+class CanonicalTypeName a where+  canonicalTypeName :: Proxy a -> Text+  default canonicalTypeName :: (Typeable a) => Proxy a -> Text+  canonicalTypeName p = renderStableTypeRep (someTypeRep p)++-- ** Built-in instances ------------------------------------------------------++--+-- Default instances for the common scalar and primitive container types+-- that a typical 'RegFile' carries. Each is empty-bodied, picking up the+-- 'Typeable' default. Users who want a custom canonical name override+-- with a non-empty instance.++instance CanonicalTypeName ()++instance CanonicalTypeName Bool++instance CanonicalTypeName Char++instance CanonicalTypeName Int++instance CanonicalTypeName Int8++instance CanonicalTypeName Int16++instance CanonicalTypeName Int32++instance CanonicalTypeName Int64++instance CanonicalTypeName Integer++instance CanonicalTypeName Word++instance CanonicalTypeName Word8++instance CanonicalTypeName Word16++instance CanonicalTypeName Word32++instance CanonicalTypeName Word64++instance CanonicalTypeName Double++instance CanonicalTypeName Float++instance CanonicalTypeName Text++instance CanonicalTypeName UTCTime++instance CanonicalTypeName Day++instance (Typeable a) => CanonicalTypeName (Maybe a)++instance (Typeable a) => CanonicalTypeName [a]++instance (Typeable a, Typeable b) => CanonicalTypeName (Either a b)++instance (Typeable a, Typeable b) => CanonicalTypeName (a, b)++instance (Typeable a, Typeable b, Typeable c) => CanonicalTypeName (a, b, c)++-- * Shape hash --------------------------------------------------------------++-- | The class governing slot-lists that carry a shape hash. The+-- inductive method 'regFileShapeCanonical' assembles the pre-hash+-- canonical encoding; 'regFileShapeHash' (top-level, below) is the+-- SHA-256 of that encoding in lower-case hex.+--+-- Per EP-36 §3 R3 the hash is a single SHA-256 over the byte+-- concatenation of, for each slot in slot-list order,+--+-- > <slotSymbol> ":" <renderStableTypeRep tr> ";"+--+-- with the empty list anchored at the literal canonical form+-- @"regfile:0"@. The recursive structure of the class is therefore+-- /string/ concatenation, not nested hashing — the byte-string is built+-- end-to-end and hashed once. This means a slot-list of length /n/+-- performs exactly one SHA-256, not /n/ chained ones.+class KnownRegFileShape (rs :: [Slot]) where+  -- | The full canonical pre-hash encoding of the slot list. Exposed+  -- so that consumers can attach their own hash algorithm or use the+  -- canonical form for debugging; 'regFileShapeHash' wraps this in+  -- SHA-256.+  regFileShapeCanonical :: Proxy rs -> Text++instance KnownRegFileShape '[] where+  regFileShapeCanonical _ = T.pack "regfile:0"++instance+  ( KnownSymbol s,+    CanonicalTypeName t,+    KnownRegFileShape rs+  ) =>+  KnownRegFileShape ('(s, t) ': rs)+  where+  regFileShapeCanonical _ =+    T.concat+      [ T.pack (symbolVal (Proxy @s)),+        T.pack ":",+        canonicalTypeName (Proxy @t),+        T.pack ";",+        regFileShapeCanonical (Proxy @rs)+      ]++-- | Shape hash of a slot list, as lower-case hexadecimal SHA-256 over+-- the UTF-8 bytes of 'regFileShapeCanonical'. Pure, no 'IO'.+regFileShapeHash :: forall rs. (KnownRegFileShape rs) => Proxy rs -> Text+regFileShapeHash p = sha256Hex (regFileShapeCanonical p)++-- * TypeRep rendering -------------------------------------------------------++-- | Render a 'SomeTypeRep' as a stable, application-tree-shaped string.+-- Each 'TyCon' contributes @<tyConModule>.<tyConName>@; applied type+-- arguments are rendered recursively and surrounded by parentheses,+-- comma-separated.+--+-- Examples (the exact module names depend on the GHC base layout; the+-- shape is what's guaranteed):+--+-- > renderStableTypeRep (someTypeRep (Proxy @Int))         = "GHC.Types.Int"+-- > renderStableTypeRep (someTypeRep (Proxy @(Maybe Int))) = "GHC.Internal.Maybe.Maybe(GHC.Types.Int)"+--+-- The implementation uses only 'tyConModule', 'tyConName', and+-- 'splitApps' — never 'tyConPackage' (which varies with cabal version+-- pins), never 'Show' on 'TypeRep' (which is not contractually stable),+-- and never the raw 'Type.Reflection.Fingerprint'. See EP-36 §3 R5+-- and §5 P5.+renderStableTypeRep :: SomeTypeRep -> Text+renderStableTypeRep (SomeTypeRep tr) = renderTypeRep tr++renderTypeRep :: forall k (a :: k). TypeRep a -> Text+renderTypeRep tr =+  let (tc, args) = splitApps tr+      base =+        T.pack (tyConModule tc)+          <> T.pack "."+          <> T.pack (tyConName tc)+   in case args of+        [] -> base+        _ ->+          base+            <> T.pack "("+            <> T.intercalate (T.pack ",") (map renderStableTypeRep args)+            <> T.pack ")"++-- * SHA-256 helper ----------------------------------------------------------++-- | SHA-256 over the UTF-8 encoding of the input, rendered as+-- lower-case hexadecimal.+sha256Hex :: Text -> Text+sha256Hex =+  T.pack . concatMap byteToHex . BS.unpack . SHA256.hash . TE.encodeUtf8++byteToHex :: Word8 -> String+byteToHex b =+  [ intToDigit (fromIntegral (b `shiftR` 4)),+    intToDigit (fromIntegral (b .&. 0x0F))+  ]
+ src/Keiki/Symbolic.hs view
@@ -0,0 +1,887 @@+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeFamilies #-}++-- | SBV-backed symbolic surface for 'Keiki.Core' predicates.+--+-- This module is the v2 symbolic upgrade of the v1 best-effort+-- @BoolAlg HsPred@ instance pinned by EP-4 of MasterPlan 1's+-- Outcomes & Retrospective. After EP-2 of MasterPlan 2, asking+-- "are these two edge guards mutually exclusive?" is a mechanical+-- question with a precise answer; the synthesis-§7 invariant that+-- edge guards form an /effective/ Boolean algebra is honored at v2.+--+-- The module re-exports everything from "Keiki.Core" so a single+-- import is sufficient for callers that need both the pure and the+-- symbolic surfaces. See @docs/research/sbv-boolalg-design.md@ for+-- the design rationale.+--+-- Milestones implemented in this revision (through M5 of EP-2):+--+--   * The 'Sym' typeclass and instances for 'Bool', 'Int', 'Integer',+--     'Text', 'UTCTime', and the fixed-width integers 'Word8' \/+--     'Word16' \/ 'Word32' \/ 'Word64' \/ 'Int32' \/ 'Int64' (the+--     last group added by EP-41 so money and count registers are+--     solver-visible).+--   * 'SymEnv' carrying the shared symbolic input-constructor tag and+--     (since EP-42 of MasterPlan 12) an 'IORef' memo cache that shares+--     one SBV variable per register slot / input field across repeated+--     reads, so @proj #x .== proj #x@ is valid, not merely satisfiable.+--   * 'translateTermSym' / 'translatePred' walking 'Term' / 'HsPred'+--     into SBV expressions.+--   * 'discoverSym' — runtime dispatch from 'Typeable' to 'Sym'+--     evidence over the curated registry of supported types.+--   * 'SymPred' newtype wrapper plus its 'BoolAlg' instance with+--     structural 'top' / 'bot' / 'conj' / 'disj' / 'neg', a 'models'+--     that re-uses the v1 'evalPred' (concrete evaluation, no solver+--     call), and an 'isBot' backed by z3.+--   * 'symIsBot' — pure-API wrapper around SBV's solver call (via+--     'unsafePerformIO' + NOINLINE) that 'SymPred''s 'isBot' routes+--     through, so the v1 syntactic over-approximation is replaced with a+--     precise symbolic answer.+--   * 'symSatExt' — full witness extraction. Since EP-44 (MasterPlan 12)+--     the 'Keiki.Core.Sat' method 'sat' on 'SymPred' /is/+--     'symSatExt' (via the @Sat (SymPred …)@ instance, which carries the+--     'ExtractRegFile' / 'KnownInCtors' evidence witness reconstruction+--     needs); the old crashing placeholder is gone.+module Keiki.Symbolic+  ( -- * Symbolic representation+    Sym (..),+    SymDict (..),+    symLit,+    symFree,+    discoverSym,+    SymOrdDict (..),+    discoverSymOrd,+    SymNumDict (..),+    discoverSymNum,++    -- * Translation+    SymEnv (..),+    mkSymEnv,+    translateTermSym,+    translatePred,++    -- * Symbolic predicate wrapper+    SymPred (..),+    SymGuarded,++    -- * Solver-backed analyses+    symIsBot,+    symSatExt,++    -- * Witness extraction+    ExtractRegFile (..),+    SomeInCtor (..),+    KnownInCtors (..),++    -- * Single-valuedness+    isSingleValuedSym,+    withSymPred,++    -- * Solver-backed validation diagnostics (EP-56)+    checkTransitionDeterminismSym,+    checkDeadEdgesSym,++    -- * Re-exports+    module Keiki.Core,+  )+where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Int (Int32, Int64)+import Data.Kind (Type)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Proxy (Proxy (..))+import Data.SBV qualified as SBV+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Data.Typeable (Typeable)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Keiki.Core+import System.IO.Unsafe (unsafePerformIO)+import Type.Reflection (eqTypeRep, typeRep, type (:~~:) (HRefl))++-- * Symbolic representation -------------------------------------------------++-- | A type that has a curated representation in the SBV symbolic+-- universe. The associated type 'SymRep' pins the SBV-friendly+-- representation; the 'toSym' / 'fromSym' round-trip lets us push+-- concrete Haskell values into the solver and pull concrete witnesses+-- out of a model.+--+-- The 'SBV.SymVal' superclass on 'SymRep' gives us 'SBV.literal',+-- 'SBV.free', and 'SBV.unliteral' for free.+--+-- 'symDefault' is consumed by 'symSatExt': when the solver's model+-- has no value for a slot or input field that the predicate did not+-- reference, the witness extractor falls back to 'symDefault'. Sound+-- because such slots are unconstrained — any value satisfies the+-- predicate.+class (SBV.SymVal (SymRep a), Typeable a) => Sym a where+  type SymRep a :: Type+  toSym :: a -> SymRep a+  fromSym :: SymRep a -> a+  symDefault :: a++instance Sym Bool where+  type SymRep Bool = Bool+  toSym = id+  fromSym = id+  symDefault = False++instance Sym Integer where+  type SymRep Integer = Integer+  toSym = id+  fromSym = id+  symDefault = 0++-- | Encoded as 'Integer'. SBV does not provide an 'SInt'-of-arbitrary-+-- size; using 'Integer' avoids overflow surprises during translation.+instance Sym Int where+  type SymRep Int = Integer+  toSym = fromIntegral+  fromSym = fromIntegral+  symDefault = 0++-- The fixed-width integer instances below all encode as the unbounded+-- mathematical 'Integer', exactly like 'Sym Int'. This is an+-- /over-approximation/: the modular wraparound of the Haskell @Word*@ /+-- @Int*@ type is not modeled. The consequence is sound for+-- satisfiability (every concrete model the solver finds is a real+-- witness once decoded through 'fromSym') but may miss an+-- unsatisfiability that depends on overflow (e.g. @x + 1 == 0@ over+-- 'Word64' is satisfiable at the type's wrap point but the 'Integer'+-- encoding reports it unsat). keiki's money and count guards are+-- equality and ordering checks against in-range literals, where the+-- over-approximation never bites. The motivating money type is+-- @Jitsurei.OrderCart@'s @Money = Word64@ (fixed-point minor units).++-- | Money and large counts. Encoded as 'Integer'; see the note above+-- on the unbounded-'Integer' over-approximation.+instance Sym Word64 where+  type SymRep Word64 = Integer+  toSym = fromIntegral+  fromSym = fromIntegral+  symDefault = 0++-- | Item counts and similar 32-bit unsigned registers. Encoded as+-- 'Integer'; see the over-approximation note above.+instance Sym Word32 where+  type SymRep Word32 = Integer+  toSym = fromIntegral+  fromSym = fromIntegral+  symDefault = 0++-- | Quantities, basis points, and similar 16-bit unsigned registers.+-- Encoded as 'Integer'; see the over-approximation note above.+instance Sym Word16 where+  type SymRep Word16 = Integer+  toSym = fromIntegral+  fromSym = fromIntegral+  symDefault = 0++-- | 8-bit unsigned (completeness). Encoded as 'Integer'; see the+-- over-approximation note above.+instance Sym Word8 where+  type SymRep Word8 = Integer+  toSym = fromIntegral+  fromSym = fromIntegral+  symDefault = 0++-- | 64-bit signed (completeness). Encoded as 'Integer'; see the+-- over-approximation note above.+instance Sym Int64 where+  type SymRep Int64 = Integer+  toSym = fromIntegral+  fromSym = fromIntegral+  symDefault = 0++-- | 32-bit signed (completeness). Encoded as 'Integer'; see the+-- over-approximation note above.+instance Sym Int32 where+  type SymRep Int32 = Integer+  toSym = fromIntegral+  fromSym = fromIntegral+  symDefault = 0++-- | 'Text' is encoded as Haskell 'String' for SBV's 'SString' theory.+instance Sym Text where+  type SymRep Text = String+  toSym = T.unpack+  fromSym = T.pack+  symDefault = T.empty++-- | 'UTCTime' is encoded as Unix epoch seconds (an 'Integer').+-- The round-trip drops sub-second precision; this is intentional —+-- the User Registration aggregate's timestamps are at-second+-- granularity already, and Integer-encoded time comparisons are well+-- supported by SBV's z3 backend.+instance Sym UTCTime where+  type SymRep UTCTime = Integer+  toSym = round . utcTimeToPOSIXSeconds+  fromSym = posixSecondsToUTCTime . fromIntegral+  symDefault = posixSecondsToUTCTime 0++-- | Reify a 'Sym' instance so it can be passed around as a+-- first-class value. Useful for runtime dispatch on 'Typeable'+-- evidence.+data SymDict r where+  SymDict :: (Sym r) => SymDict r++-- | Try to discover a 'Sym' instance for @r@ at runtime. Returns+-- @Just SymDict@ for any of the curated supported types+-- ('Bool', 'Int', 'Integer', 'Text', 'UTCTime', and the fixed-width+-- integers 'Word8' \/ 'Word16' \/ 'Word32' \/ 'Word64' \/ 'Int32' \/+-- 'Int64'); 'Nothing' otherwise. The translator uses this to route+-- 'PEq' over arbitrary types: a 'Sym' hit translates to '(.==)' on+-- SBV terms; a miss falls back to a fresh 'SBool' (loses precision but+-- stays sound).+discoverSym :: forall r. (Typeable r) => Maybe (SymDict r)+discoverSym+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Bool) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Integer) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Text) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @UTCTime) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word64) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word32) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word16) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word8) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int64) = Just SymDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int32) = Just SymDict+  | otherwise = Nothing++-- | Reify both a 'Sym' instance for @r@ and evidence that its+-- 'SymRep' is symbolically orderable (an 'SBV.OrdSymbolic' instance on+-- @'SBV.SBV' ('SymRep' r)@). This is exactly what 'PCmp' translation+-- needs: 'Sym' to push the operands into SBV, 'OrdSymbolic' to emit a+-- real @.<@ \/ @.<=@ \/ @.>@ \/ @.>=@ comparison.+data SymOrdDict r where+  SymOrdDict :: (Sym r, SBV.OrdSymbolic (SBV.SBV (SymRep r))) => SymOrdDict r++-- | Try to discover ordering evidence for @r@ at runtime, companion to+-- 'discoverSym'. Returns @Just SymOrdDict@ for the numeric and time+-- types whose 'SymRep' is an 'SBV.OrdSymbolic' 'Integer' ('Int',+-- 'Integer', the fixed-width integers 'Word8' \/ 'Word16' \/ 'Word32'+-- \/ 'Word64' \/ 'Int32' \/ 'Int64', and 'UTCTime' encoded as epoch+-- seconds); 'Nothing' otherwise. 'Bool' and 'Text' are deliberately+-- omitted: ordering a 'Bool' guard is not meaningful, and 'SString'+-- ordering is out of scope here. A 'Nothing' makes the 'PCmp'+-- translator fall back to a fresh opaque 'SBool', exactly as 'goEq'+-- does for non-'Sym' operands — sound, just imprecise.+discoverSymOrd :: forall r. (Typeable r) => Maybe (SymOrdDict r)+discoverSymOrd+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Integer) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word64) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word32) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word16) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word8) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int64) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int32) = Just SymOrdDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @UTCTime) = Just SymOrdDict+  | otherwise = Nothing++-- | Reify both a 'Sym' instance for @r@ and evidence that its 'SymRep'+-- is symbolically /numeric/ (a 'Num' instance on @'SBV.SBV' ('SymRep'+-- r)@). This is what 'TArith' translation needs: 'Sym' to push the+-- operands into SBV, 'Num' to emit a real @+@ \/ @-@ \/ @*@ over the+-- translated terms. Companion to 'discoverSym' \/ 'discoverSymOrd'+-- (EP-43).+data SymNumDict r where+  SymNumDict :: (Sym r, Num (SBV.SBV (SymRep r))) => SymNumDict r++-- | Try to discover numeric evidence for @r@ at runtime, companion to+-- 'discoverSymOrd'. Returns @Just SymNumDict@ for the numeric types+-- whose 'SymRep' is the SBV-'Num' 'Integer' ('Int', 'Integer', and the+-- fixed-width integers 'Word8' \/ 'Word16' \/ 'Word32' \/ 'Word64' \/+-- 'Int32' \/ 'Int64'); 'Nothing' otherwise. 'Bool', 'Text', and+-- 'UTCTime' are omitted — not meaningfully arithmetic here. A 'Nothing'+-- makes the 'TArith' translator fall back to a fresh opaque variable,+-- exactly as 'goEq' \/ 'goCmp' fall back for non-'Sym' operands —+-- sound, just imprecise. (The 'Num' constraint on the 'TArith'+-- constructor already prevents arithmetic at non-numeric types, so this+-- fallback is only reachable for a numeric type intentionally left out+-- of the registry.)+discoverSymNum :: forall r. (Typeable r) => Maybe (SymNumDict r)+discoverSymNum+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int) = Just SymNumDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Integer) = Just SymNumDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word64) = Just SymNumDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word32) = Just SymNumDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word16) = Just SymNumDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Word8) = Just SymNumDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int64) = Just SymNumDict+  | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Int32) = Just SymNumDict+  | otherwise = Nothing++-- | Lift a concrete value to an SBV literal of its 'SymRep'.+symLit :: forall a. (Sym a) => a -> SBV.SBV (SymRep a)+symLit = SBV.literal . toSym++-- | Allocate a fresh symbolic variable of the carrier's 'SymRep'.+symFree :: forall a. (Sym a) => String -> SBV.Symbolic (SBV.SBV (SymRep a))+symFree = SBV.free++-- * Translation environment -------------------------------------------------++-- | Translation context: shared symbolic state that must be threaded+-- through a single predicate's walk so that, for example, two+-- 'PInCtor' atoms over distinct constructors agree they cannot both+-- be true, and two reads of the same register (or input field) share+-- one solver variable.+--+-- Two pieces of state are shared:+--+--   * 'seInputCtor' — the symbolic input-constructor tag, so 'PInCtor'+--     atoms over distinct constructors are recognized as mutually+--     unsatisfiable.+--   * 'seVarCache' — a per-translation memo cache (EP-42) keyed by the+--     deterministic variable name ('TReg' allocates @"reg/\<slot\>"@,+--     'TInpCtorField' allocates @"inp/\<ctor\>/\<field\>"@). The first+--     read of a name allocates one 'SBV.free' variable and stores it;+--     every later read of the same name returns the cached variable.+--     This makes the solver see two reads of @#x@ as the /same/ value,+--     so @proj #x .== proj #x@ is valid (not merely satisfiable). The+--     'TApp1' \/ 'TApp2' escape hatches are deliberately /not/ cached:+--     they wrap opaque Haskell functions with no 'Eq', so two+--     applications cannot be recognized as equal and each stays a fresh+--     per-occurrence variable.+data SymEnv = SymEnv+  { -- | The shared symbolic input constructor tag. 'PInCtor' atoms+    --     assert @seInputCtor .== literal (icName ic)@; the solver+    --     recognizes that two such constraints with distinct names are+    --     mutually unsatisfiable.+    seInputCtor :: SBV.SBV String,+    -- | Memo cache: maps a deterministic variable name ("reg/\<slot\>"+    --     or "inp/\<ctor\>/\<field\>") to the single SBV variable allocated+    --     for it during this predicate translation. Lazily populated on+    --     first read so unread slots stay unconstrained (and 'symSatExt'+    --     falls back to 'symDefault' for them). Scoped to one+    --     'translatePred' walk (one 'mkSymEnv'), so variables are shared+    --     /within/ a query but never leak across independent queries.+    seVarCache :: IORef (Map String SomeSBV)+  }++-- | An SBV variable of some representation type, packed so the memo+-- cache in 'SymEnv' can hold variables of different representation+-- types under one map. 'SBV.SymVal' has a 'Typeable' superclass, so+-- pattern-matching @SomeSBV (v :: SBV.SBV a)@ brings @Typeable a@ into+-- scope — exactly what 'memoFree' needs to check the recovered type+-- matches the requested one on a cache hit.+data SomeSBV where+  SomeSBV :: (SBV.SymVal a) => SBV.SBV a -> SomeSBV++-- | Allocate a fresh 'SymEnv'. Lives in 'SBV.Symbolic' because+-- 'seInputCtor' is a free symbolic variable and the memo cache is an+-- 'IORef' created in the underlying 'IO' ('SBV.Symbolic' is+-- @SymbolicT IO@, hence 'MonadIO').+mkSymEnv :: SBV.Symbolic SymEnv+mkSymEnv = do+  ctor <- SBV.free "inputCtor"+  cache <- liftIO (newIORef Map.empty)+  pure (SymEnv ctor cache)++-- * Translation -------------------------------------------------------------++-- | Translate a 'Term rs ci r' to an SBV expression of the carrier's+-- representation type. Requires 'Sym' evidence for @r@.+--+-- The translation is /structural/ for 'TLit', 'TReg',+-- 'TInpCtorField', and (since EP-43) 'TArith': a 'TArith' over a type+-- whose 'SymRep' is SBV-numeric (a 'discoverSymNum' hit) emits a real+-- @+@ \/ @-@ \/ @*@ over the translated operands, so a guard over a+-- /computed/ value is visible to the solver. 'TApp1' and 'TApp2' wrap+-- opaque Haskell functions and translate to fresh SBV variables of the+-- result type — sound but imprecise; 'TArith' falls back to the same+-- fresh variable only if its (numeric) operand type is absent from the+-- 'discoverSymNum' registry.+--+-- Variable naming (consumed by 'symSatExt' for witness extraction):+--+--   * 'TReg' allocates @"reg/<slotName>"@ where @slotName@ is the+--     slot's label recovered from the 'Index'\'s 'KnownSymbol'+--     evidence on its leaf 'ZIdx'.+--   * 'TInpCtorField' allocates+--     @"inp/<icName>/<slotName>"@ — the 'InCtor''s name plus the+--     field's slot label.+--   * 'TApp1' / 'TApp2' keep their anonymous names; their values are+--     not extracted as part of the witness.+--+-- Note on repeated reads (EP-42): 'TReg' and 'TInpCtorField' reads are+-- memoized through the env's 'seVarCache'. The first read of a given+-- slot\/field allocates one 'SBV.free' variable and caches it under its+-- deterministic name; every later read of the same name returns the+-- cached variable. So two reads of the same slot (e.g.+-- @proj #x .== proj #x@) share /one/ SBV variable: the solver knows+-- they are equal, @x \/= x@ is unsat, and 'symSatExt''s by-name witness+-- extraction is correct for repeated reads. The 'TApp1' \/ 'TApp2'+-- escape hatches stay per-occurrence fresh (their opaque functions+-- have no 'Eq', so two applications cannot be recognized as equal);+-- their values are not part of the extracted witness.+translateTermSym ::+  forall rs ci ifs r.+  (Sym r) =>+  SymEnv ->+  Term rs ci ifs r ->+  SBV.Symbolic (SBV.SBV (SymRep r))+translateTermSym _env (TLit r) = pure (symLit r)+translateTermSym env (TReg ix) =+  memoFree env ("reg/" <> indexName ix)+translateTermSym env (TInpCtorField ic ix) =+  memoFree env ("inp/" <> icName ic <> "/" <> indexName ix)+translateTermSym _env (TApp1 _f _t) = SBV.free "app1"+translateTermSym _env (TApp2 _f _a _b) = SBV.free "app2"+translateTermSym env (TArith op a b) = case discoverSymNum @r of+  Nothing -> SBV.free "arith" -- sound opaque fallback+  Just SymNumDict -> do+    sa <- translateTermSym env a+    sb <- translateTermSym env b+    let apply = case op of+          OpAdd -> (+)+          OpSub -> (-)+          OpMul -> (*)+    pure (apply sa sb)++-- | Memoized symbolic-variable allocator (EP-42). Looks @name@ up in+-- the env's 'seVarCache'. On a hit, recover the cached SBV variable —+-- checking its representation type matches the requested one, which it+-- always does because a deterministic name maps to exactly one type.+-- On a miss, allocate a fresh 'SBV.free', store it under @name@, and+-- return it. This is what makes repeated reads of the same register or+-- input field share a single solver variable.+memoFree ::+  forall a.+  (SBV.SymVal a) =>+  SymEnv -> String -> SBV.Symbolic (SBV.SBV a)+memoFree env name = do+  m <- liftIO (readIORef (seVarCache env))+  case Map.lookup name m of+    Just (SomeSBV (v :: SBV.SBV b)) ->+      case eqTypeRep (typeRep @a) (typeRep @b) of+        Just HRefl -> pure v+        Nothing ->+          -- Unreachable: a name maps to exactly one representation type.+          error ("memoFree: type mismatch for cached variable " <> name)+    Nothing -> do+      v <- SBV.free name+      liftIO (modifyIORef' (seVarCache env) (Map.insert name (SomeSBV v)))+      pure v++-- | Recover the slot name an 'Index' points at by walking to the+-- leaf 'ZIdx' and reading off the 'KnownSymbol' evidence the+-- constructor carries. Used for deterministic SBV variable naming+-- in 'translateTermSym'.+indexName :: forall rs r. Index rs r -> String+indexName (ZIdx @s) = symbolVal (Proxy @s)+indexName (SIdx i) = indexName i++-- | Translate an 'HsPred' to an SBV 'SBool'. The translation is+-- structural for every constructor:+--+--   * 'PTop' / 'PBot' map to @sTrue@ / @sFalse@.+--   * 'PAnd' / 'POr' / 'PNot' map to '(SBV..&&)' / '(SBV..||)' /+--     'SBV.sNot' on the recursive translations.+--   * 'PEq' tries 'discoverSym' on its operand type; on a hit it+--     emits '(.==)' between the two translated terms; on a miss it+--     emits a fresh 'SBool' (the equality is opaque to the solver).+--   * 'PInCtor' emits @seInputCtor .== literal (icName ic)@; the+--     shared 'seInputCtor' makes constructor-mutual-exclusion+--     decidable.+--   * 'PCmp' tries 'discoverSymOrd' on its operand type; on a hit it+--     emits the matching SBV comparison ('SBV..<' \/ '.<=' \/ '.>' \/+--     '.>=') between the two translated terms; on a miss it emits a+--     fresh 'SBool' (the comparison is opaque to the solver).+translatePred ::+  forall rs ci. SymEnv -> HsPred rs ci -> SBV.Symbolic SBV.SBool+translatePred env = go+  where+    go :: HsPred rs ci -> SBV.Symbolic SBV.SBool+    go PTop = pure SBV.sTrue+    go PBot = pure SBV.sFalse+    go (PAnd p q) = (SBV..&&) <$> go p <*> go q+    go (POr p q) = (SBV..||) <$> go p <*> go q+    go (PNot p) = SBV.sNot <$> go p+    go (PEq a b) = goEq a b+    go (PInCtor ic) = pure (seInputCtor env SBV..== SBV.literal (icName ic))+    go (PCmp op a b) = goCmp op a b++    goEq ::+      forall r ifs1 ifs2.+      (Typeable r) =>+      Term rs ci ifs1 r -> Term rs ci ifs2 r -> SBV.Symbolic SBV.SBool+    goEq a b = case discoverSym @r of+      Nothing -> SBV.free "neq"+      Just SymDict -> do+        sa <- translateTermSym env a+        sb <- translateTermSym env b+        pure (sa SBV..== sb)++    goCmp ::+      forall r ifs1 ifs2.+      (Typeable r) =>+      Cmp -> Term rs ci ifs1 r -> Term rs ci ifs2 r -> SBV.Symbolic SBV.SBool+    goCmp op a b = case discoverSymOrd @r of+      Nothing -> SBV.free "cmp" -- sound opaque fallback+      Just SymOrdDict -> do+        sa <- translateTermSym env a+        sb <- translateTermSym env b+        let apply = case op of+              CmpLt -> (SBV..<)+              CmpLe -> (SBV..<=)+              CmpGt -> (SBV..>)+              CmpGe -> (SBV..>=)+        pure (apply sa sb)++-- * Symbolic predicate wrapper ----------------------------------------------++-- | A newtype wrapper over 'HsPred' that selects the v2 'BoolAlg'+-- instance (with SBV-backed analyses) instead of the v1 syntactic+-- one. The v1 'BoolAlg HsPred' instance in "Keiki.Core" stays+-- unchanged for back-compat; consumers that want symbolic answers+-- wrap with 'SymPred'.+--+-- The 'SymPred' constructor is exported so callers can lift+-- @userReg@-style transducers via 'fmap'-like adapters; M6 of EP-2+-- ships 'withSymPred' which re-tags every edge guard.+newtype SymPred (rs :: [Slot]) (ci :: Type) = SymPred {unSymPred :: HsPred rs ci}++-- | A 'SymTransducer' whose guard carrier is the SBV-backed 'SymPred'.+-- The symbolic analogue of 'Keiki.Core.Guarded'.+type SymGuarded rs s ci co = SymTransducer (SymPred rs ci) rs s ci co++-- | The v2 'BoolAlg' instance. The five structural methods compose+-- 'HsPred' constructors. 'models' delegates to the v1 'evalPred'+-- (concrete evaluation, no solver call). 'isBot' routes through+-- 'symIsBot', which dispatches to z3 via SBV. Witness extraction+-- ('Keiki.Core.sat') lives in the separate 'Sat' instance below, which+-- carries the 'ExtractRegFile' / 'KnownInCtors' evidence it needs; this+-- instance is deliberately /unconstrained/ so the witness-free analyses+-- ('isSingleValuedSym') keep type-checking on register-file-existential+-- carriers and on @ci@ types with no 'KnownInCtors'.+instance BoolAlg (SymPred rs ci) (RegFile rs, ci) where+  top = SymPred PTop+  bot = SymPred PBot+  conj (SymPred p) (SymPred q) = SymPred (PAnd p q)+  disj (SymPred p) (SymPred q) = SymPred (POr p q)+  neg (SymPred p) = SymPred (PNot p)+  models (SymPred p) (regs, ci) = evalPred p regs ci+  isBot (SymPred p) = symIsBot p++-- | Witness extraction for the SBV-backed carrier (EP-44, MasterPlan+-- 12). @'sat' (SymPred p)@ returns the same real, forceable witness as+-- 'symSatExt' — a concrete @(RegFile rs, ci)@ reconstructed from the+-- solver model. The constraints @ExtractRegFile rs@ / @KnownInCtors ci@+-- live here (not on 'BoolAlg') so only witness extraction pays for them.+instance+  (ExtractRegFile rs, KnownInCtors ci) =>+  Sat (SymPred rs ci) (RegFile rs, ci)+  where+  sat (SymPred p) = symSatExt p++-- * Solver-backed analyses --------------------------------------------------++-- | Symbolic emptiness check. Translates the predicate to an SBV+-- expression and asks z3 whether any model exists; @True@ when none+-- does (the predicate is bot), @False@ otherwise (including the+-- conservative 'Unknown' fallback). The 'unsafePerformIO' wrapper is+-- justified because every SBV query is deterministic for a given+-- predicate and side-effect-free outside the solver process.+{-# NOINLINE symIsBot #-}+symIsBot :: HsPred rs ci -> Bool+symIsBot p = unsafePerformIO $ do+  res <- SBV.sat $ do+    env <- mkSymEnv+    translatePred env p+  pure (not (SBV.modelExists res))++-- * Single-valuedness ------------------------------------------------------++-- | A transducer is /single-valued/ when, at every reachable+-- vertex, at most one outgoing edge's guard is satisfied for any+-- given input. The check decomposes into "for every vertex @s@, for+-- every distinct pair @(e1, e2)@ of outgoing edges, is the+-- conjunction of their guards 'isBot'?". The function is+-- 'BoolAlg'-polymorphic; precision depends on the chosen 'isBot'+-- implementation. With 'SymPred', this is the v2 SBV-backed+-- decision; with the v1 'HsPred' instance the answer is the v1+-- syntactic over-approximation.+isSingleValuedSym ::+  forall phi rs s ci co.+  (BoolAlg phi (RegFile rs, ci), Bounded s, Enum s) =>+  SymTransducer phi rs s ci co ->+  Bool+isSingleValuedSym t = all vertexSV [minBound .. maxBound]+  where+    vertexSV :: s -> Bool+    vertexSV s =+      let es = edgesOut t s+          ies = zip [(0 :: Int) ..] es+          pairs =+            [ (e1, e2)+            | (i, e1) <- ies,+              (j, e2) <- ies,+              i < j+            ]+       in all (\(e1, e2) -> isBot (guard e1 `conj` guard e2)) pairs++-- | Lift a transducer's edges from the v1 'HsPred' guard carrier to+-- the v2 'SymPred' carrier so 'isSingleValuedSym' (or any other+-- 'BoolAlg'-polymorphic analysis) sees the SBV-backed instance.+-- The control graph and update / output terms are unchanged.+withSymPred ::+  SymTransducer (HsPred rs ci) rs s ci co ->+  SymTransducer (SymPred rs ci) rs s ci co+withSymPred t =+  SymTransducer+    { edgesOut = \s -> map liftEdge (edgesOut t s),+      initial = initial t,+      initialRegs = initialRegs t,+      isFinal = isFinal t+    }+  where+    liftEdge ::+      Edge (HsPred rs ci) rs ci co s ->+      Edge (SymPred rs ci) rs ci co s+    liftEdge e@Edge {update = u} =+      Edge+        { guard = SymPred (guard e),+          update = u,+          output = output e,+          target = target e+        }++-- * Solver-backed validation diagnostics (EP-56) ---------------------------++-- | Solver-backed determinism diagnostic. Lifts the transducer with+-- 'withSymPred' and runs the 'BoolAlg'-polymorphic 'checkTransitionDeterminism'+-- at the 'SymPred' carrier, whose 'isBot' is the exact z3 decision. Unlike the+-- pure path in 'validateTransducer', this catches register-value-dependent and+-- other non-syntactic overlaps. Requires z3 on @PATH@.+checkTransitionDeterminismSym ::+  (Bounded s, Enum s, Show s) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  [DeterminismWarning s]+checkTransitionDeterminismSym = checkTransitionDeterminism . withSymPred++-- | Symbolic dead-edge sketch. Flags edges whose guard is unsatisfiable+-- /in isolation/ (via 'symIsBot'), which the structural 'checkDeadEdges'+-- misses unless the guard is literally 'PBot' (e.g. @amount > 0 && amount < 0@).+-- It does NOT compute the register configurations reachable at each vertex, so+-- it still cannot catch the FieldResource case (a guard satisfiable in+-- isolation but never under the registers reachable there); that needs a full+-- reachable-state fixpoint and is left as future work. Requires z3 on @PATH@.+checkDeadEdgesSym ::+  (Bounded s, Enum s, Show s) =>+  SymTransducer (HsPred rs ci) rs s ci co ->+  [DeadEdgeWarning s]+checkDeadEdgesSym t =+  [ DeadEdgeWarning+      (EdgeRef {edgeSource = s, edgeIndex = i})+      "guard is unsatisfiable in isolation (symbolic)"+  | s <- [minBound .. maxBound],+    (i, e) <- zip [(0 :: Int) ..] (edgesOut t s),+    symIsBot (guard e)+  ]++-- * Witness extraction -----------------------------------------------------++-- | Materialize a 'RegFile' from a name-keyed reader. The reader's+-- input is a slot name (the same string 'translateTermSym' allocates+-- under @"reg/" <> slotName@); the reader's output is the slot's+-- value, of any 'Sym'-supported type. The reader is total: callers+-- (notably 'symSatExt') fall back to 'symDefault' for slots whose+-- names the SBV model did not bind.+--+-- Two instances cover the slot list:+--+--   * @ExtractRegFile \'[]@ — return 'RNil' regardless of the reader.+--   * @ExtractRegFile (\'(s, t) ': rs)@ — read the head slot's name+--     via the reader, recurse on the tail, build an 'RCons'.+--+-- The instance constraints @KnownSymbol s@ and @Sym t@ make this+-- automatic for any concrete slot list whose value types are in the+-- curated 'Sym' registry ('Bool', 'Int', 'Integer', 'Text',+-- 'UTCTime'). User Registration's 'UserRegRegs' shape qualifies+-- without further user code.+class ExtractRegFile (rs :: [Slot]) where+  extractRegFile :: (forall r. (Sym r) => String -> r) -> RegFile rs++instance ExtractRegFile '[] where+  extractRegFile _ = RNil++instance+  ( KnownSymbol s,+    Sym t,+    ExtractRegFile rs+  ) =>+  ExtractRegFile ('(s, t) ': rs)+  where+  extractRegFile reader =+    RCons+      (Proxy @s)+      (reader @t (symbolVal (Proxy @s)))+      (extractRegFile @rs reader)++-- | Existential wrapper around an 'InCtor' that hides the+-- input-field slot list. The hidden 'ExtractRegFile' constraint lets+-- 'symSatExt' rebuild the input register file once the constructor+-- tag is known from the SBV model.+data SomeInCtor (ci :: Type) where+  SomeInCtor :: (ExtractRegFile ifs) => InCtor ci ifs -> SomeInCtor ci++-- | A 'ci' type whose set of 'InCtor's is statically known. Each+-- 'SomeInCtor' bag entry pairs an 'InCtor' value with the+-- 'ExtractRegFile' evidence its field-list shape requires.+--+-- For the User Registration aggregate, the instance is a five-line+-- list pairing the existing @inCtorStart@ … @inCtorContinue@+-- declarations:+--+-- > instance KnownInCtors UserCmd where+-- >   allInCtors =+-- >     [ SomeInCtor inCtorStart+-- >     , SomeInCtor inCtorConfirm+-- >     , SomeInCtor inCtorResend+-- >     , SomeInCtor inCtorGdpr+-- >     , SomeInCtor inCtorContinue+-- >     ]+--+-- Future work: a Generic-derived default via 'GHasCtor' so users+-- get the instance for free with @deriving (Generic)@. Out of scope+-- for EP-9 because the explicit list is already one line per+-- constructor.+class KnownInCtors ci where+  allInCtors :: [SomeInCtor ci]++-- | The single zero-field constructor of @()@ — a transducer whose+-- command alphabet carries no information. Lets 'symSatExt' (and hence+-- 'Keiki.Core.sat') reconstruct a @()@ witness for predicates over+-- @SymPred rs ()@.+inCtorUnit :: InCtor () '[]+inCtorUnit =+  InCtor+    { icName = "()",+      icMatch = \() -> Just RNil,+      icBuild = \RNil -> ()+    }++-- | @()@ has one constructor; its 'allInCtors' is the singleton+-- 'inCtorUnit'. Added by EP-44 so @sat@ over a no-command carrier+-- (@SymPred '[] ()@) yields a real @(RNil, ())@ witness.+instance KnownInCtors () where+  allInCtors = [SomeInCtor inCtorUnit]++-- * symSatExt ---------------------------------------------------------------++-- | Symbolic satisfiability with full witness extraction. On a+-- satisfiable predicate, returns @Just (regs, cmd)@ where @regs@+-- and @cmd@ are concrete values reconstructed from the SBV model.+-- @models p (regs, cmd) == True@ holds for the returned witness,+-- modulo one known limitation:+--+--   * /Escape-hatch terms/ ('TApp1', 'TApp2', and 'PEq' over a+--     non-'Sym' operand type, the @neq@ fallback in 'goEq').+--     These translate to fresh anonymous SBV variables; their values+--     are not extracted, and two occurrences of the same opaque+--     application do not share a variable (opaque functions have no+--     'Eq'). The witness reflects only the slots and input-fields the+--     predicate references through 'TReg' and 'TInpCtorField'.+--+-- /Repeated reads/ of the same register or input field are handled+-- correctly: since EP-42 'translateTermSym' memoizes 'TReg' \/+-- 'TInpCtorField' reads (see 'SymEnv'\'s 'seVarCache'), so two reads of+-- @#x@ share one SBV variable and the by-name witness extraction+-- satisfies @proj #x .== proj #x@-style structural equality.+--+-- The model's input-constructor tag is confined to the known+-- constructor domain (@KnownInCtors ci@), so a predicate without a+-- 'PInCtor' atom still reconstructs a real command (the first/only+-- constructor) rather than failing to match an arbitrary solver string.+--+-- 'symSatExt' is /pure/ via 'unsafePerformIO' on the SBV solver+-- call (deterministic for a given predicate, side-effect-free+-- outside the solver process). Since EP-44 it /is/ the implementation+-- of the 'Keiki.Core.Sat' method 'sat' on 'SymPred' (via the+-- @Sat (SymPred …)@ instance, which carries the 'ExtractRegFile' /+-- 'KnownInCtors' evidence the witness-free 'BoolAlg' class cannot).+{-# NOINLINE symSatExt #-}+symSatExt ::+  forall rs ci.+  ( ExtractRegFile rs,+    KnownInCtors ci+  ) =>+  HsPred rs ci -> Maybe (RegFile rs, ci)+symSatExt p = unsafePerformIO $ do+  res <- SBV.sat $ do+    env <- mkSymEnv+    b <- translatePred env p+    -- Constrain the shared input-constructor tag to the known+    -- constructor domain so the solver cannot pick a string matching no+    -- constructor. Predicates without a 'PInCtor' atom leave the tag+    -- free, so without this the solver could choose an unknown tag,+    -- 'pickCi' would find no match, and a satisfiable predicate would+    -- (wrongly) yield no witness. Confining the tag to the real finite+    -- domain keeps the reconstructed witness sound (it always satisfies+    -- 'models') and improves completeness on @PNot (PInCtor …)@ guards.+    let ctorNames = [icName ic | SomeInCtor ic <- allInCtors @ci]+    when (not (null ctorNames)) $+      SBV.constrain $+        SBV.sOr [seInputCtor env SBV..== SBV.literal n | n <- ctorNames]+    pure b+  pure $+    if SBV.modelExists res+      then do+        ctorTag <- SBV.getModelValue "inputCtor" res+        let regReader :: forall r. (Sym r) => String -> r+            regReader name = readModel res ("reg/" <> name)+        let regs = extractRegFile @rs regReader+        ci <-+          pickCi @ci+            ctorTag+            ( \icN fieldName ->+                readModel+                  res+                  ("inp/" <> icN <> "/" <> fieldName)+            )+        pure (regs, ci)+      else Nothing++-- | Look up @name@ in @res@'s SBV model; on a hit return @fromSym@+-- of the model value, on a miss return @symDefault@. Used by+-- 'symSatExt' to convert SBV's typed model lookups into Haskell+-- values for any 'Sym'-supported slot type.+readModel :: forall r. (Sym r) => SBV.SatResult -> String -> r+readModel res name =+  case SBV.getModelValue name res :: Maybe (SymRep r) of+    Just rep -> fromSym rep+    Nothing -> symDefault++-- | Walk the 'allInCtors' list, find the entry whose 'icName'+-- matches the model's input-constructor tag, then 'extractRegFile'+-- over the matched 'InCtor''s field list and call 'icBuild' to+-- assemble a @ci@. Returns 'Nothing' when no entry matches the tag+-- — this is the case when the predicate over-allocated the+-- @"inputCtor"@ slot (the solver picked a string that isn't any+-- known constructor name, which can happen if the predicate+-- doesn't include any 'PInCtor' atom).+pickCi ::+  forall ci.+  (KnownInCtors ci) =>+  String ->+  (forall r. (Sym r) => String -> String -> r) ->+  Maybe ci+pickCi tag readField = go (allInCtors @ci)+  where+    go [] = Nothing+    go (SomeInCtor ic@InCtor {} : rest)+      | icName ic == tag =+          let regs = extractRegFile (readField (icName ic))+           in Just (icBuild ic regs)+      | otherwise = go rest
+ test/Keiki/AcceptorSpec.hs view
@@ -0,0 +1,95 @@+module Keiki.AcceptorSpec (spec) where++import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import Keiki.Acceptor+import Keiki.Core (initialRegs, isFinal, reconstitute)+import Keiki.Fixtures.EmailDelivery+  ( EmailEvent (..),+    EmailSentData (..),+    emailDelivery,+  )+import Keiki.Fixtures.UserRegistration+  ( AccountConfirmedData (..),+    ConfirmAccountData (..),+    FulfillGDPRRequestData (..),+    StartRegistrationData (..),+    UserCmd (..),+    UserEvent (..),+    Vertex (..),+    userReg,+  )+import Test.Hspec++-- | A trivial UTC-time fixture: every test moment is on the same day,+-- offset by N seconds.+t :: Integer -> UTCTime+t s = UTCTime (fromGregorian 2026 5 1) (secondsToDiffTime s)++-- | The canonical four-step command sequence on 'userReg' that lands+-- in the final 'Deleted' vertex.+--+--   PotentialCustomer    --StartRegistration->  Registering+--   Registering          --Continue->           RequiresConfirmation+--   RequiresConfirmation --ConfirmAccount->     Confirmed+--   Confirmed            --FulfillGDPRRequest-> Deleted+--+-- The 'ConfirmAccount' code matches the code stored at registration,+-- so the @PEq@ guard on the confirmation edge is satisfied.+-- EP-19 M7: 'Continue' retired with the collapsed entrance.+-- StartRegistration alone now drives PotentialCustomer →+-- RequiresConfirmation as one transition emitting both+-- RegistrationStarted and ConfirmationEmailSent.+canonicalUserCmds :: [UserCmd]+canonicalUserCmds =+  [ StartRegistration (StartRegistrationData "alice@x" "Z9F4" (t 0)),+    ConfirmAccount (ConfirmAccountData "Z9F4" (t 100)),+    FulfillGDPRRequest (FulfillGDPRRequestData (t 200))+  ]++-- | The canonical event log on 'emailDelivery' that lands in the+-- terminal 'EmailSentVertex'.+canonicalEmailLog :: [EmailEvent]+canonicalEmailLog =+  [EmailSent (EmailSentData "alice@x" "Welcome" (t 0))]++spec :: Spec+spec = do+  describe "inputAcceptor userReg" $ do+    it "accepts the canonical command sequence" $+      accepts (inputAcceptor userReg) canonicalUserCmds+        `shouldBe` True++    it "rejects ConfirmAccount from PotentialCustomer" $+      accepts+        (inputAcceptor userReg)+        [ConfirmAccount (ConfirmAccountData "Z9F4" (t 0))]+        `shouldBe` False++  describe "outputAcceptor emailDelivery" $ do+    it "accepts the canonical event log" $+      accepts (outputAcceptor emailDelivery) canonicalEmailLog+        `shouldBe` True++    it "rejects an event that no edge from PotentialCustomer produces" $ do+      -- userReg's only outgoing edge from PotentialCustomer produces+      -- 'RegistrationStarted'; 'AccountConfirmed' has no matching+      -- inverse, so applyEvent returns Nothing on the first step.+      let badLog =+            [ AccountConfirmed+                (AccountConfirmedData "alice@x" "Z9F4" (t 0))+            ]+      accepts (outputAcceptor userReg) badLog `shouldBe` False++    it "agrees with reconstitute on the canonical log" $+      fmap fst (runAcceptor (outputAcceptor emailDelivery) canonicalEmailLog)+        `shouldBe` fmap fst (reconstitute emailDelivery canonicalEmailLog)++  describe "aIsFinal" $ do+    it "matches isFinal on userReg under fst" $ do+      let a = inputAcceptor userReg+      aIsFinal a (Deleted, initialRegs userReg) `shouldBe` True+      aIsFinal a (Confirmed, initialRegs userReg) `shouldBe` False+      aIsFinal a (PotentialCustomer, initialRegs userReg) `shouldBe` False+      -- And the same predicate on the bare vertex.+      isFinal userReg Deleted `shouldBe` True+      isFinal userReg Confirmed `shouldBe` False
+ test/Keiki/ArrowSpec.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE BlockArguments #-}++-- | Acceptance tests for the 'Control.Arrow.Arrow' instance on+-- 'SomeSymTransducer' (EP-29 of MasterPlan 9, M3).+--+-- The Arrow instance lifts arbitrary Haskell functions via+-- 'Arr.arr' (a stateless one-edge transducer whose 'WireCtor's+-- 'wcBuild' applies the function), and inherits 'Arr.first' /+-- 'Arr.second' from the 'Strong' instance. @(>>>)@ comes from the+-- 'Cat.Category' instance.+--+-- /Composition limitation:/ 'arr f >>> arr g' does NOT produce+-- 'arr (g . f)' on this wrapper — see 'arrTransducer' haddock for+-- the @icName == wcName@ alignment reason. The spec covers the+-- standalone-arr forward eval, sentinel preservation, first+-- delegation, and the documented 'solveOutput' lossy contract.+module Keiki.ArrowSpec (spec) where++import Control.Arrow qualified as Arr+import Control.Category qualified as Cat+import Data.Text (Text)+import Data.Text qualified as Text+import Keiki.Core+import Keiki.Profunctor+import Test.Hspec++-- * Specs -------------------------------------------------------------------++spec :: Spec+spec = do+  describe "arr" $ do+    it "lifts (Text.pack . show) :: SomeSymTransducer Int Text" $ do+      let lifted :: SomeSymTransducer Int Text+          lifted = Arr.arr (Text.pack . show)+      case lifted of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (42 :: Int)+            `shouldBe` [("42" :: Text)]+        SomeSymIdentity ->+          expectationFailure+            "Arr.arr unexpectedly returned the identity sentinel"++    it "lifts identity-shaped functions but does not detect them as Cat.id" $ do+      -- Arr.arr id has the identity *behaviour* on every input but+      -- the wrapper cannot observe Haskell function identity, so it+      -- materialises into a SomeSymTransducer rather than the+      -- sentinel. This is the documented behaviour.+      let lifted :: SomeSymTransducer Int Int+          lifted = Arr.arr (id :: Int -> Int)+      case lifted of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (7 :: Int)+            `shouldBe` [7]+        SomeSymIdentity ->+          expectationFailure+            "Arr.arr id should NOT short-circuit to SomeSymIdentity \+            \— Haskell function identity is unobservable at the value level"++  describe "first via Arrow's first method (delegates to Strong.first')" $ do+    it "first (arr show) on (42, \"extra\") emits (\"42\", \"extra\")" $ do+      let lifted :: SomeSymTransducer (Int, Text) (String, Text)+          lifted = Arr.first (Arr.arr show)+      case lifted of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (42 :: Int, "extra" :: Text)+            `shouldBe` [("42", "extra")]+        SomeSymIdentity ->+          expectationFailure+            "Arr.first on a non-identity wrapper returned the sentinel"++  describe "Cat.id and the Arrow instance interplay" $ do+    it "Cat.id passes through arr-style values verbatim" $+      -- This exercises that the Arrow instance's superclass dispatch+      -- of (>>>) hits the sentinel short-circuit when one operand is+      -- the sentinel. arr f >>> Cat.id should equal arr f+      -- behaviourally.+      let lifted :: SomeSymTransducer Int Text+          lifted = Arr.arr (Text.pack . show) Cat.>>> Cat.id+       in case lifted of+            SomeSymTransducer t ->+              omega t (initial t) (initialRegs t) (99 :: Int)+                `shouldBe` [("99" :: Text)]+            SomeSymIdentity ->+              expectationFailure+                "arr f >>> Cat.id unexpectedly returned the sentinel \+                \— the sentinel short-circuit returns the non-sentinel arg, \+                \so we expect SomeSymTransducer here"++    it "Cat.id <<< arr f passes through verbatim too" $+      let lifted :: SomeSymTransducer Int Text+          lifted = Cat.id Cat.<<< Arr.arr (Text.pack . show)+       in case lifted of+            SomeSymTransducer t ->+              omega t (initial t) (initialRegs t) (5 :: Int)+                `shouldBe` [("5" :: Text)]+            SomeSymIdentity ->+              expectationFailure+                "Cat.id <<< arr f unexpectedly returned the sentinel"
+ test/Keiki/BuilderSpec.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TemplateHaskell #-}++-- | EP-15 M6: hand-written unit tests for 'Keiki.Builder'. Tests use+-- a tiny in-spec toy transducer (single-slot register file, two+-- vertices, one or two edges) so each behaviour is exercised in+-- isolation.+module Keiki.BuilderSpec (spec) where++import Control.Exception (evaluate)+import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import GHC.Generics (Generic)+import Keiki.Builder ((.=), (=:))+import Keiki.Builder qualified as B+import Keiki.Core+  ( Edge (..),+    HsPred (..),+    Index,+    OutFields (..),+    RegFile,+    SymTransducer (..),+    applyEvent,+    delta,+    lit,+    omega,+  )+import Keiki.Core qualified as K+import Keiki.Generics (emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveWireCtors)+import Test.Hspec++-- * Toy transducer ---------------------------------------------------------++-- Single-slot register file. The slot's value is set by the+-- 'Tick' command and emitted by the 'TickEvent' wire ctor.+type Regs = '[ '("counter", Int)]++emptyR :: RegFile Regs+emptyR = emptyRegFile++data ToyVertex = A | B+  deriving (Eq, Show, Enum, Bounded)++data TickData = TickData {count :: Int}+  deriving (Eq, Show, Generic)++data ToyCmd = Tick TickData | Idle+  deriving (Eq, Show, Generic)++data TickEventData = TickEventData {count :: Int}+  deriving (Eq, Show, Generic)++data ToyEvent = Ticked TickEventData+  deriving (Eq, Show, Generic)++$( deriveAggregateCtors+     ''ToyCmd+     ''Regs+     [ ("Tick", "Tick"),+       ("Idle", "Idle")+     ]+ )++$( deriveWireCtors+     ''ToyEvent+     [ ("Ticked", "Ticked")+     ]+ )++t0 :: UTCTime+t0 = UTCTime (fromGregorian 2026 5 2) (secondsToDiffTime 0)++-- * Auxiliary toy: 2-slot register file for case 2 -----------------------++type TwoRegs = '[ '("x", Int), '("y", Int)]++emptyTwoR :: RegFile TwoRegs+emptyTwoR = emptyRegFile++data TwoData = TwoData {x :: Int, y :: Int}+  deriving (Eq, Show, Generic)++data TwoCmd = Two TwoData+  deriving (Eq, Show, Generic)++data TwoEventData = TwoEventData {x :: Int, y :: Int}+  deriving (Eq, Show, Generic)++data TwoEvent = TwoEv TwoEventData+  deriving (Eq, Show, Generic)++$( deriveAggregateCtors+     ''TwoCmd+     ''TwoRegs+     [ ("Two", "Two")+     ]+ )++$( deriveWireCtors+     ''TwoEvent+     [ ("TwoEv", "TwoEv")+     ]+ )++-- * Pretty-printing aids -------------------------------------------------++showGuard :: HsPred rs ci -> String+showGuard PTop = "PTop"+showGuard PBot = "PBot"+showGuard (PAnd a b) = "PAnd (" <> showGuard a <> ") (" <> showGuard b <> ")"+showGuard (POr a b) = "POr (" <> showGuard a <> ") (" <> showGuard b <> ")"+showGuard (PNot p) = "PNot (" <> showGuard p <> ")"+showGuard (PEq _ _) = "PEq <term> <term>"+showGuard (PInCtor _) = "PInCtor <ic>"++-- * Spec -------------------------------------------------------------------++spec :: Spec+spec = do+  describe "EP-15 M6: Keiki.Builder unit cases" $ do+    -- Case 1: single (.=) produces a USet whose evaluator agrees+    -- with the reference register update.+    it "case 1: single (.=) writes the slot the evaluator reads" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" .= d.count+                B.emit wireTicked (OFCons d.count OFNil)+                B.goto B+          cmd = Tick (TickData 42)+      case delta tr A emptyR cmd of+        Just (_, regs) -> regs K.! (#counter :: Index Regs Int) `shouldBe` 42+        Nothing -> expectationFailure "delta returned Nothing"++    -- Case 2: sequential (.=) to distinct slots agrees with the+    -- composite reference. Use a 2-slot register file inline.+    it "case 2: sequential (.=) to distinct slots writes both" $ do+      let tr2 = B.buildTransducer A emptyTwoR (const False) do+            B.from A do+              B.onCmd inCtorTwo $ \d -> B.do+                B.slot @"x" .= d.x+                B.slot @"y" .= d.y+                B.emit wireTwoEv (OFCons d.x (OFCons d.y OFNil))+                B.goto B+          cmd = Two (TwoData 7 11)+      case delta tr2 A emptyTwoR cmd of+        Just (_, regs) -> do+          regs K.! (#x :: Index TwoRegs Int) `shouldBe` 7+          regs K.! (#y :: Index TwoRegs Int) `shouldBe` 11+        Nothing -> expectationFailure "delta returned Nothing"++    -- Case 3: sequential (.=) to the SAME slot. Compile-time error.+    -- Not exercised here as a runtime hspec assertion: the GHC+    -- TypeError fires at compile time, not runtime, so it cannot be+    -- caught with `evaluate` / `shouldThrow` without enabling+    -- -fdefer-type-errors module-wide. Instead, the spec/spike+    -- modules' own compilation success is the (positive) proof:+    -- both type-check because they only ever write each slot once.+    -- See docs/research/edge-builder-dsl-shape.md Q1 for the worked+    -- error message.++    -- Case 4: emit followed by replay via solveOutput round-trips.+    -- For any cmd: applyEvent (omega ...) recovers the (s', regs')+    -- that delta produced.+    it "case 4: emit then solveOutput round-trips delta/applyEvent" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" .= d.count+                B.emit wireTicked (OFCons d.count OFNil)+                B.goto B+          cmd = Tick (TickData 9)+      case delta tr A emptyR cmd of+        Nothing -> expectationFailure "delta returned Nothing"+        Just (s', regs') -> case omega tr A emptyR cmd of+          [] -> expectationFailure "omega returned []"+          [co] -> case applyEvent tr A emptyR co of+            Nothing -> expectationFailure "applyEvent returned Nothing"+            Just (s'', regs'') -> do+              s'' `shouldBe` s'+              (regs'' K.! (#counter :: Index Regs Int))+                `shouldBe` (regs' K.! (#counter :: Index Regs Int))+          cos_ ->+            expectationFailure+              ( "omega returned an unexpected multi-event list of "+                  <> show (length cos_)+              )++    -- Case 5: noEmit produces an Edge whose output is [] (ε-edge).+    it "case 5: noEmit yields output = []" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \_d -> B.do+                B.noEmit+                B.goto B+      case edgesOut tr A of+        [e] -> case output e of+          [] -> pure ()+          _ -> expectationFailure "expected ε-edge but got non-empty output list"+        es -> expectationFailure ("expected exactly 1 edge, got " <> show (length es))++    -- Case 6: goto V sets target = V.+    it "case 6: goto V sets target to V" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \_d -> B.do+                B.noEmit+                B.goto B+      case edgesOut tr A of+        [e] -> target e `shouldBe` B+        _ -> expectationFailure "expected exactly 1 edge"++    -- Case 7: missing goto. Runtime error names source vertex and+    -- edge index.+    it "case 7: missing goto fires the expected runtime error" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \_d -> B.do+                B.noEmit -- intentional: no goto+      evaluate (head (edgesOut tr A))+        `shouldThrow` errorCall+          ( "Keiki.Builder: edge #0 from A: goto missing. "+              <> "Each onCmd/onEpsilon body must end with "+              <> "exactly one goto V."+          )++    -- Case 8: multiple goto. Runtime error names source vertex and+    -- edge index.+    it "case 8: multiple goto fires the expected runtime error" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \_d -> B.do+                B.goto B+                B.goto A+      evaluate (head (edgesOut tr A))+        `shouldThrow` errorCall+          ( "Keiki.Builder: edge #0 from A: goto called "+              <> "more than once. Each onCmd/onEpsilon body "+              <> "must end with exactly one goto V."+          )++    -- Case 9: requireEq extends the guard. The starting guard from+    -- onCmd is matchInCtor (a PInCtor); requireEq adds a PAnd-PEq+    -- conjunct. We assert this by structural inspection.+    it "case 9: requireEq extends the guard with PAnd-PEq" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.requireEq d.count (lit 7)+                B.noEmit+                B.goto B+      case edgesOut tr A of+        [e] -> case guard e of+          PAnd (PInCtor _) (PEq _ _) -> pure ()+          other -> expectationFailure ("guard shape mismatch: " <> showGuard other)+        _ -> expectationFailure "expected exactly 1 edge"++    -- Case 10: onEpsilon (no onCmd) builds a guard-only edge with+    -- guard = PTop.+    it "case 10: onEpsilon builds a guard-only edge with guard = PTop" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onEpsilon B.do+                B.goto B+      case edgesOut tr A of+        [e] -> case guard e of+          PTop -> pure ()+          other -> expectationFailure ("guard shape mismatch: " <> showGuard other)+        _ -> expectationFailure "expected exactly 1 edge"++    -- Case 11: two onCmd blocks under one `from` produce two+    -- edges, in order. Demonstrates that EdgeListBuilder's plain-Monad+    -- (>>=) sequences edge-list-prepends correctly and that `from`+    -- reverses them so the final edge order matches authoring order.+    it "case 11: two onCmd blocks under one `from` produce two edges in order" $ do+      let tr = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \_d -> B.do+                B.noEmit+                B.goto B+              B.onCmd inCtorIdle $ \_d -> B.do+                B.noEmit+                B.goto A+      case edgesOut tr A of+        [e1, e2] -> do+          target e1 `shouldBe` B -- Tick goes to B (first onCmd)+          target e2 `shouldBe` A -- Idle goes to A (second onCmd)+        es -> expectationFailure ("expected exactly 2 edges, got " <> show (length es))++  describe "EP-21 M4: field-keyed record sugar for B.emit" $ do+    -- Case 12: emit with the per-event record form produces the+    -- same omega output as the operator form for the same data.+    it "case 12: record-form emit and operator-form emit agree on omega" $ do+      let trRec = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" .= d.count+                B.emit wireTicked TickedTermFields {count = d.count}+                B.goto B+          trOp = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" .= d.count+                B.emit wireTicked (OFCons d.count OFNil)+                B.goto B+          cmd = Tick (TickData 17)+      omega trRec A emptyR cmd `shouldBe` omega trOp A emptyR cmd++    -- Case 13: multi-field record form preserves field-name order.+    -- Two events with shared field names compile and produce the+    -- correct OutFields under DuplicateRecordFields.+    it "case 13: record-form emit on a 2-field event applies fields in order" $ do+      let trRec = B.buildTransducer A emptyTwoR (const False) do+            B.from A do+              B.onCmd inCtorTwo $ \d -> B.do+                B.slot @"x" .= d.x+                B.slot @"y" .= d.y+                B.emit+                  wireTwoEv+                  TwoEvTermFields {x = d.x, y = d.y}+                B.goto B+          trOp = B.buildTransducer A emptyTwoR (const False) do+            B.from A do+              B.onCmd inCtorTwo $ \d -> B.do+                B.slot @"x" .= d.x+                B.slot @"y" .= d.y+                B.emit wireTwoEv (OFCons d.x (OFCons d.y OFNil))+                B.goto B+          cmd = Two (TwoData 7 11)+      omega trRec A emptyTwoR cmd `shouldBe` omega trOp A emptyTwoR cmd++    -- Case 14: emitWith (explicit InCtor) accepts the record form.+    -- Useful inside onEpsilon and as an escape hatch.+    it "case 14: emitWith with the record form produces the same omega" $ do+      let trEmitWith = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" .= d.count+                B.emitWith+                  inCtorTick+                  wireTicked+                  TickedTermFields {count = d.count}+                B.goto B+          trEmit = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" .= d.count+                B.emit+                  wireTicked+                  TickedTermFields {count = d.count}+                B.goto B+          cmd = Tick (TickData 5)+      omega trEmitWith A emptyR cmd `shouldBe` omega trEmit A emptyR cmd++  describe "EP-49: (=:) is a synonym for (.=)" $+    -- Authoring the same single-slot edge with `.=` and with `=:`+    -- produces the identical register write. `Update` carries `Term`s+    -- (which hold opaque functions) so it has no `Eq`; we compare the+    -- observable instead — the register file `delta` produces.+    it "produces the same register write as (.=) for the same slot+term" $ do+      let withDot = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" .= d.count+                B.emit wireTicked (OFCons d.count OFNil)+                B.goto B+          withColon = B.buildTransducer A emptyR (const False) do+            B.from A do+              B.onCmd inCtorTick $ \d -> B.do+                B.slot @"counter" =: d.count+                B.emit wireTicked (OFCons d.count OFNil)+                B.goto B+          cmd = Tick (TickData 42)+      case (delta withDot A emptyR cmd, delta withColon A emptyR cmd) of+        (Just (_, r1), Just (_, r2)) ->+          (r1 K.! (#counter :: Index Regs Int))+            `shouldBe` (r2 K.! (#counter :: Index Regs Int))+        _ -> expectationFailure "delta returned Nothing for one of the forms"
+ test/Keiki/BuilderSpike.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Spike for EP-15 M2: validate the builder against a tiny coffee-+-- dispenser two-vertex toy. After M3 promoted the builder to+-- 'Keiki.Builder', this module is the smallest end-to-end consumer+-- and stays in the test suite as a thin smoke test (the full unit+-- coverage is in 'Keiki.BuilderSpec' under M6).+module Keiki.BuilderSpike (spec) where++import Control.Exception (evaluate)+import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import GHC.Generics (Generic)+import Keiki.Builder ((*:), (.=))+import Keiki.Builder qualified as B+import Keiki.Core+  ( Edge (..),+    HsPred,+    Index,+    OutFields (..),+    RegFile,+    SymTransducer (..),+    Update (..),+    combine,+    delta,+    omega,+    pack,+  )+import Keiki.Core qualified as K+import Keiki.Generics (emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveWireCtors)+import Keiki.Internal.Slots (IndexN)+import Test.Hspec++-- * Coffee-dispenser toy ---------------------------------------------------++-- | Money the dispenser tracks. Two slots: the price quoted at+-- insertion time (\"price\") and a sentinel timestamp for when the+-- brew started (\"brewStartedAt\").+type CoffeeRegs =+  '[ '("price", Int),+     '("brewStartedAt", UTCTime)+   ]++emptyCoffeeRegs :: RegFile CoffeeRegs+emptyCoffeeRegs = emptyRegFile++data CoffeeVertex = Idle | Brewing+  deriving (Eq, Show, Enum, Bounded)++-- Two commands: insert money (with an amount and a timestamp); a+-- silent Continue tick that completes the brew.+data InsertData = InsertData+  { amount :: Int,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++data CoffeeCmd = Insert InsertData | Continue+  deriving (Eq, Show, Generic)++-- One event: the dispenser brewed a coffee at amount C cents.+data BrewedData = BrewedData {paid :: Int}+  deriving (Eq, Show, Generic)++data CoffeeEvent = Brewed BrewedData+  deriving (Eq, Show, Generic)++-- TH: per-input-ctor projections + guards.+$( deriveAggregateCtors+     ''CoffeeCmd+     ''CoffeeRegs+     [ ("Insert", "Insert"),+       ("Continue", "Continue")+     ]+ )++-- TH: per-event-ctor wire ctors.+$( deriveWireCtors+     ''CoffeeEvent+     [ ("Brewed", "Brewed")+     ]+ )++-- * The toy transducer, twice -----------------------------------------------++-- AST form. Two edges:+--   Idle    --[Insert]--> Brewing  emits Brewed { paid = inp.amount }+--                                  writes price=inp.amount, brewStartedAt=inp.at+--   Brewing --[Continue]-> Idle    epsilon (no event), no register changes+coffeeAST ::+  SymTransducer+    (HsPred CoffeeRegs CoffeeCmd)+    CoffeeRegs+    CoffeeVertex+    CoffeeCmd+    CoffeeEvent+coffeeAST =+  SymTransducer+    { edgesOut = coffeeASTEdges,+      initial = Idle,+      initialRegs = emptyCoffeeRegs,+      isFinal = const False+    }++coffeeASTEdges ::+  CoffeeVertex ->+  [ Edge+      (HsPred CoffeeRegs CoffeeCmd)+      CoffeeRegs+      CoffeeCmd+      CoffeeEvent+      CoffeeVertex+  ]+coffeeASTEdges = \case+  Idle ->+    [ Edge+        { guard = isInsert,+          update =+            USet+              (#price :: IndexN "price" CoffeeRegs Int)+              (inpInsert #amount)+              `combine` USet+                (#brewStartedAt :: IndexN "brewStartedAt" CoffeeRegs UTCTime)+                (inpInsert #at),+          output =+            [ pack+                inCtorInsert+                wireBrewed+                (OFCons (inpInsert #amount) OFNil)+            ],+          target = Brewing+        }+    ]+  Brewing ->+    [ Edge+        { guard = isContinue,+          update = UKeep,+          output = [],+          target = Idle+        }+    ]++-- Builder form. Reads as sequential commands.+--+-- The outer @do@ is plain (VertexBuilder is a regular Monad); the+-- per-vertex @do@ is also plain (EdgeListBuilder is a regular Monad);+-- only the per-edge body uses 'B.do' because it is the indexed-state+-- layer that threads the type-level slot-set.+coffeeBuilt ::+  SymTransducer+    (HsPred CoffeeRegs CoffeeCmd)+    CoffeeRegs+    CoffeeVertex+    CoffeeCmd+    CoffeeEvent+coffeeBuilt = B.buildTransducer Idle emptyCoffeeRegs (const False) do+  B.from Idle do+    B.onCmd inCtorInsert $ \d -> B.do+      B.slot @"price" .= d.amount+      B.slot @"brewStartedAt" .= d.at+      B.emit wireBrewed (d.amount *: B.oNil)+      B.goto Brewing++  B.from Brewing do+    B.onCmd inCtorContinue $ \_d -> B.do+      B.goto Idle++-- * Misuse demonstrations --------------------------------------------------++-- A transducer with a missing-goto edge. Top-level binding evaluation+-- raises the finalize-time error; we wrap in an IO action and use+-- 'evaluate' to force the error in-spec.+coffeeMissingGoto ::+  SymTransducer+    (HsPred CoffeeRegs CoffeeCmd)+    CoffeeRegs+    CoffeeVertex+    CoffeeCmd+    CoffeeEvent+coffeeMissingGoto = B.buildTransducer Idle emptyCoffeeRegs (const False) do+  B.from Idle do+    B.onCmd inCtorInsert $ \_d -> B.do+      -- intentional: no goto+      B.noEmit++-- A transducer with two gotos in one body.+coffeeDoubleGoto ::+  SymTransducer+    (HsPred CoffeeRegs CoffeeCmd)+    CoffeeRegs+    CoffeeVertex+    CoffeeCmd+    CoffeeEvent+coffeeDoubleGoto = B.buildTransducer Idle emptyCoffeeRegs (const False) do+  B.from Idle do+    B.onCmd inCtorInsert $ \_d -> B.do+      B.goto Brewing+      B.goto Idle++-- * In-spec assertions -----------------------------------------------------++t0 :: UTCTime+t0 = UTCTime (fromGregorian 2026 5 2) (secondsToDiffTime 0)++t100 :: UTCTime+t100 = UTCTime (fromGregorian 2026 5 2) (secondsToDiffTime 100)++t200 :: UTCTime+t200 = UTCTime (fromGregorian 2026 5 2) (secondsToDiffTime 200)++spec :: Spec+spec = do+  describe "EP-15 M2 spike: builder vs AST agreement" $ do+    it "delta and omega agree on Idle + Insert" $ do+      let cmd = Insert (InsertData 250 t0)+      fmap fst (delta coffeeAST Idle emptyCoffeeRegs cmd)+        `shouldBe` fmap fst (delta coffeeBuilt Idle emptyCoffeeRegs cmd)+      omega coffeeAST Idle emptyCoffeeRegs cmd+        `shouldBe` omega coffeeBuilt Idle emptyCoffeeRegs cmd++    it "delta and omega agree on Brewing + Continue" $ do+      let insertCmd = Insert (InsertData 250 t0)+      Just (_, regs) <- pure (delta coffeeAST Idle emptyCoffeeRegs insertCmd)+      fmap fst (delta coffeeAST Brewing regs Continue)+        `shouldBe` fmap fst (delta coffeeBuilt Brewing regs Continue)+      omega coffeeAST Brewing regs Continue+        `shouldBe` omega coffeeBuilt Brewing regs Continue++    it "delta is Nothing on Idle + Continue (guard mismatch)" $ do+      fmap fst (delta coffeeAST Idle emptyCoffeeRegs Continue) `shouldBe` Nothing+      fmap fst (delta coffeeBuilt Idle emptyCoffeeRegs Continue) `shouldBe` Nothing++    it "omega round-trips event through the AST and builder forms" $ do+      let cmd = Insert (InsertData 300 t100)+      omega coffeeAST Idle emptyCoffeeRegs cmd+        `shouldBe` [(Brewed (BrewedData 300))]+      omega coffeeBuilt Idle emptyCoffeeRegs cmd+        `shouldBe` [(Brewed (BrewedData 300))]++  describe "EP-15 M2 spike: misuse error messages" $ do+    it "missing goto fires at finalize time with the expected message" $+      -- `head` forces the first element of the edges list, which is+      -- the result of `finalizeEdge`. `length` would only walk the+      -- spine and not trigger the error.+      evaluate (head (edgesOut coffeeMissingGoto Idle))+        `shouldThrow` errorCall+          ( "Keiki.Builder: edge #0 from Idle: goto missing. "+              <> "Each onCmd/onEpsilon body must end with "+              <> "exactly one goto V."+          )++    it "duplicated goto fires at finalize time with the expected message" $+      evaluate (head (edgesOut coffeeDoubleGoto Idle))+        `shouldThrow` errorCall+          ( "Keiki.Builder: edge #0 from Idle: goto called "+              <> "more than once. Each onCmd/onEpsilon body must "+              <> "end with exactly one goto V."+          )++  describe "EP-15 M2 spike: timestamp also threads correctly" $+    it "second slot 'brewStartedAt' is written" $ do+      let cmd = Insert (InsertData 200 t200)+      Just (_, regs1) <- pure (delta coffeeAST Idle emptyCoffeeRegs cmd)+      Just (_, regs2) <- pure (delta coffeeBuilt Idle emptyCoffeeRegs cmd)+      (regs1 K.! (#brewStartedAt :: Index CoffeeRegs UTCTime))+        `shouldBe` (regs2 K.! (#brewStartedAt :: Index CoffeeRegs UTCTime))
+ test/Keiki/CategorySpec.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE BlockArguments #-}++-- | Acceptance tests for the 'Control.Category.Category' instance on+-- 'SomeSymTransducer' (EP-28 of MasterPlan 9).+--+-- The fixture is the existing 'Keiki.Fixtures.EmailDelivery'+-- aggregate and the identity transducer shipped from+-- 'Keiki.Profunctor'. Tests assert the three Category laws (left+-- identity, right identity, associativity) up to state-isomorphism+-- via forward output equality, plus the runtime+-- 'CategoryOverlapError' path and survival of 'isSingleValuedSym'+-- across @id . t@.+module Keiki.CategorySpec (spec) where++import Control.Category (id, (.))+import Control.Category qualified as Cat+import Control.Exception (evaluate)+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+import Keiki.Core+import Keiki.Fixtures.EmailDelivery+import Keiki.Profunctor+import Keiki.Symbolic (isSingleValuedSym, withSymPred)+import Test.Hspec+import Prelude hiding (id, (.))++-- * Fixtures ----------------------------------------------------------------++sampleAt :: UTCTime+sampleAt = UTCTime (fromGregorian 2026 5 9) (secondsToDiffTime 0)++sampleSendEmail :: EmailCmd+sampleSendEmail =+  SendEmail+    SendEmailData+      { recipient = "alice@example.com",+        subject = "hello",+        at = sampleAt+      }++sampleEmailEvent :: EmailEvent+sampleEmailEvent =+  EmailSent+    EmailSentData+      { recipient = "alice@example.com",+        subject = "hello",+        at = sampleAt+      }++-- | @emailDelivery@ wrapped in the existential.+someEmail :: SomeSymTransducer EmailCmd EmailEvent+someEmail = someSymTransducer emailDelivery++-- | An "adapted" copy of @emailDelivery@ whose input alphabet is+-- bridged from 'EmailEvent' back to 'EmailCmd' via 'lmapCi'. Used+-- by the overlap test: @adaptedEmail Cat.. someEmail@ has middle+-- alphabet 'EmailEvent' and forces both halves to share+-- @emailDelivery@'s @EmailRegs@ slots, triggering+-- 'CategoryOverlapError'.+--+-- The 'lmapCi' step poisons @icBuild@ on the rewritten transducer+-- ('Keiki.Profunctor.lmapCi''s documented variance caveat) but the+-- forward-only overlap assertion below never invokes+-- 'Keiki.Core.solveOutput', so the poisoned 'icBuild' is harmless+-- here.+adaptedEmail :: SomeSymTransducer EmailEvent EmailEvent+adaptedEmail = someSymTransducer (lmapCi eventToCmd emailDelivery)+  where+    eventToCmd :: EmailEvent -> EmailCmd+    eventToCmd (EmailSent d) =+      SendEmail+        SendEmailData+          { recipient = d.recipient,+            subject = d.subject,+            at = d.at+          }++-- * Behavioural-equality helpers --------------------------------------------++-- | Run @omega@ on the inner transducer of a 'SomeSymTransducer'+-- starting from its initial state and return the wire output.+-- Behavioural equality between @t1@ and @t2@ on input @ci@ is+-- defined as @runOmega t1 ci == runOmega t2 ci@.+--+-- The 'SomeSymIdentity' sentinel returns its input verbatim — by+-- definition, that is what 'Cat.id' means.+runOmega :: SomeSymTransducer ci co -> ci -> [co]+runOmega (SomeSymTransducer t) ci =+  omega t (initial t) (initialRegs t) ci+runOmega SomeSymIdentity ci = [ci]++-- * Specs -------------------------------------------------------------------++spec :: Spec+spec = do+  describe "Cat.id" $ do+    it "lifts identityTransducer at any alphabet" $ do+      let identityAtCmd :: SomeSymTransducer EmailCmd EmailCmd+          identityAtCmd = id+      runOmega identityAtCmd sampleSendEmail+        `shouldBe` [sampleSendEmail]++    it "round-trips an EmailEvent through its EmailEvent identity" $ do+      let identityAtEvent :: SomeSymTransducer EmailEvent EmailEvent+          identityAtEvent = id+      runOmega identityAtEvent sampleEmailEvent+        `shouldBe` [sampleEmailEvent]++  describe "Category laws (behavioural, up to state-isomorphism)" $ do+    it "L1 left identity: id . t behaves like t on a representative input" $+      runOmega (id . someEmail) sampleSendEmail+        `shouldBe` runOmega someEmail sampleSendEmail++    it "L2 right identity: t . id behaves like t on a representative input" $+      runOmega (someEmail . id) sampleSendEmail+        `shouldBe` runOmega someEmail sampleSendEmail++    it "L3 associativity: (t3 . t2) . t1 == t3 . (t2 . t1) on a representative input" $+      let t1 = someEmail+          t2 = id :: SomeSymTransducer EmailEvent EmailEvent+          t3 = id :: SomeSymTransducer EmailEvent EmailEvent+          left = (t3 . t2) . t1+          right = t3 . (t2 . t1)+       in runOmega left sampleSendEmail+            `shouldBe` runOmega right sampleSendEmail++    it "L1 with concrete output: id . someEmail still emits the wire EmailEvent" $+      runOmega (id . someEmail) sampleSendEmail+        `shouldBe` [sampleEmailEvent]++  describe "CategoryOverlapError on slot-name collision" $ do+    it "raises when both halves share register slots" $ do+      -- adaptedEmail's slot list is the same as emailDelivery's+      -- (EmailRegs); composing them on the EmailEvent boundary+      -- forces the runtime check to fail on all three EmailRegs+      -- slots.+      let composed = adaptedEmail . someEmail+      evaluate composed+        `shouldThrow` ( \e ->+                          let slots = coeSlots e+                           in "emailRecipient" `elem` slots+                                && "emailSubject" `elem` slots+                                && "emailSentAt" `elem` slots+                      )++    it "does NOT raise when one half is the empty-slot identity" $ do+      -- id has rs = '[], so Disjoint reduces statically; the+      -- runtime check finds no overlap.+      let composedL = id . someEmail+          composedR = someEmail . id+      runOmega composedL sampleSendEmail `shouldBe` [sampleEmailEvent]+      runOmega composedR sampleSendEmail `shouldBe` [sampleEmailEvent]++  describe "isSingleValuedSym survives id . t" $ do+    it "single-valuedness is preserved across left identity" $+      case id . someEmail of+        SomeSymTransducer t ->+          isSingleValuedSym (withSymPred t) `shouldBe` True+        SomeSymIdentity ->+          expectationFailure+            "id . someEmail unexpectedly short-circuited to SomeSymIdentity \+            \— someEmail is not the identity sentinel"++    it "single-valuedness is preserved across right identity" $+      case someEmail . id of+        SomeSymTransducer t ->+          isSingleValuedSym (withSymPred t) `shouldBe` True+        SomeSymIdentity ->+          expectationFailure+            "someEmail . id unexpectedly short-circuited to SomeSymIdentity"
+ test/Keiki/ChoiceSpec.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE BlockArguments #-}++-- | Acceptance tests for the 'Data.Profunctor.Choice.Choice' instance+-- on 'SomeSymTransducer' (EP-29 of MasterPlan 9, M1).+--+-- The Choice instance routes @Either@-shaped inputs to one of two+-- arms: @left'@ wraps the underlying transducer into the @Left@ arm+-- and lifts an identity transducer into the @Right@ arm; @right'@ is+-- the symmetric routing. The implementation delegates to+-- 'Keiki.Composition.alternative' with 'identityTransducer' on the+-- pass-through arm.+--+-- Fixture: 'Keiki.Fixtures.EmailDelivery' wrapped in+-- 'someSymTransducer'. The tests cover:+--+--   * Forward routing — a @Left@ input lands on the wrapped arm's+--     edges and emits a @Left@ wire event; a @Right@ input passes+--     straight through unchanged.+--   * Survival of 'Keiki.Symbolic.isSingleValuedSym'.+--   * Sentinel preservation: @left' Cat.id == Cat.id@ on the wrapper+--     by construction (the instance returns 'SomeSymIdentity' on the+--     sentinel arm).+module Keiki.ChoiceSpec (spec) where++import Control.Category qualified as Cat+import Data.Profunctor (Choice (..))+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+import Keiki.Core+import Keiki.Fixtures.EmailDelivery+import Keiki.Profunctor+import Keiki.Symbolic (isSingleValuedSym, withSymPred)+import Test.Hspec++-- * Fixtures ----------------------------------------------------------------++sampleAt :: UTCTime+sampleAt = UTCTime (fromGregorian 2026 5 9) (secondsToDiffTime 0)++sampleSendEmail :: EmailCmd+sampleSendEmail =+  SendEmail+    SendEmailData+      { recipient = "alice@example.com",+        subject = "hello",+        at = sampleAt+      }++sampleEmailEvent :: EmailEvent+sampleEmailEvent =+  EmailSent+    EmailSentData+      { recipient = "alice@example.com",+        subject = "hello",+        at = sampleAt+      }++someEmail :: SomeSymTransducer EmailCmd EmailEvent+someEmail = someSymTransducer emailDelivery++-- * Specs -------------------------------------------------------------------++spec :: Spec+spec = do+  describe "left'" $ do+    it "Left input routes through the wrapped transducer" $ do+      let routedLeft :: SomeSymTransducer (Either EmailCmd Int) (Either EmailEvent Int)+          routedLeft = left' someEmail+      case routedLeft of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (Left sampleSendEmail)+            `shouldBe` [(Left sampleEmailEvent)]+        SomeSymIdentity ->+          expectationFailure+            "left' (someSymTransducer emailDelivery) unexpectedly returned \+            \the identity sentinel"++    it "Right input passes through unchanged on the identity arm" $ do+      let routedLeft :: SomeSymTransducer (Either EmailCmd Int) (Either EmailEvent Int)+          routedLeft = left' someEmail+      case routedLeft of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (Right (42 :: Int))+            `shouldBe` [(Right 42)]+        SomeSymIdentity ->+          expectationFailure+            "left' (someSymTransducer emailDelivery) unexpectedly returned \+            \the identity sentinel"++    it "preserves Cat.id on the sentinel: left' Cat.id == Cat.id" $ do+      let lifted :: SomeSymTransducer (Either Int Bool) (Either Int Bool)+          lifted = left' (Cat.id :: SomeSymTransducer Int Int)+      case lifted of+        SomeSymIdentity -> pure ()+        SomeSymTransducer _ ->+          expectationFailure "left' Cat.id should preserve the identity sentinel"++  describe "right'" $ do+    it "Right input routes through the wrapped transducer" $ do+      let routedRight :: SomeSymTransducer (Either Int EmailCmd) (Either Int EmailEvent)+          routedRight = right' someEmail+      case routedRight of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (Right sampleSendEmail)+            `shouldBe` [(Right sampleEmailEvent)]+        SomeSymIdentity ->+          expectationFailure+            "right' (someSymTransducer emailDelivery) unexpectedly returned \+            \the identity sentinel"++    it "Left input passes through unchanged on the identity arm" $ do+      let routedRight :: SomeSymTransducer (Either Int EmailCmd) (Either Int EmailEvent)+          routedRight = right' someEmail+      case routedRight of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (Left (7 :: Int))+            `shouldBe` [(Left 7)]+        SomeSymIdentity ->+          expectationFailure+            "right' (someSymTransducer emailDelivery) unexpectedly returned \+            \the identity sentinel"++    it "preserves Cat.id on the sentinel: right' Cat.id == Cat.id" $ do+      let lifted :: SomeSymTransducer (Either Bool Int) (Either Bool Int)+          lifted = right' (Cat.id :: SomeSymTransducer Int Int)+      case lifted of+        SomeSymIdentity -> pure ()+        SomeSymTransducer _ ->+          expectationFailure "right' Cat.id should preserve the identity sentinel"++  describe "isSingleValuedSym survives left' / right'" $ do+    it "single-valuedness is preserved across left'" $+      case left' someEmail ::+             SomeSymTransducer (Either EmailCmd Int) (Either EmailEvent Int) of+        SomeSymTransducer t ->+          isSingleValuedSym (withSymPred t) `shouldBe` True+        SomeSymIdentity ->+          expectationFailure+            "left' on a non-identity wrapper returned the identity sentinel"++    it "single-valuedness is preserved across right'" $+      case right' someEmail ::+             SomeSymTransducer (Either Int EmailCmd) (Either Int EmailEvent) of+        SomeSymTransducer t ->+          isSingleValuedSym (withSymPred t) `shouldBe` True+        SomeSymIdentity ->+          expectationFailure+            "right' on a non-identity wrapper returned the identity sentinel"
+ test/Keiki/CollectionSpike.hs view
@@ -0,0 +1,467 @@+-- | EP-60 M1 ratification-gate spike — first-class collection registers.+--+-- This module is a __prototype__, not the final implementation. Per the EP-60+-- ratification gate it deliberately touches __no__ file under @src/Keiki/@: it+-- models the proposed collection vocabulary (FR1–FR6 of+-- @docs/research/collection-registers-design.md@) as a /local mini-AST/ and proves,+-- by construction plus runnable @hspec@ assertions, that the design satisfies its+-- invariants (INV1–INV6) before any core edit is made.+--+-- What it demonstrates:+--+--   * __FR1\/FR2\/FR4 (zero-@TApp@ authoring).__ A @BlockerBoard@ aggregate+--     (@Map BlockerId BlockerState@) is authored entirely with structural+--     constructors — @CInsert@\/@CDelete@\/@CAdjust@ carrying /terms/, never+--     closures. A structural walker confirms the whole program contains zero+--     opaque escape hatches.+--   * __INV1 (derived replay).__ A forward fold of the structural updates+--     reconstitutes the same @Map@ a reference @Data.Map@ fold produces, over a+--     finite enumeration of command sequences — no hand-written @apply@.+--   * __INV2 (@solveOutput@ invertibility).__ A model of @stepOne@'s+--     recoverability classification shows @TLookupField@ joins @TReg@ on the+--     /structural/ side (register-recoverable), distinct from the opaque @TApp@+--     side — so an edge emitting a @TLookupField@-derived field stays invertible.+--   * __INV3 (@checkHiddenInputs@ understands collection updates).__ A model of+--     the @updateReadsInput@ + union-coverage walk flags a silent ε-edge insert+--     while passing an insert whose element data is on the wire.+--   * __INV4 (static output arity).__ Each edge's output length is constant,+--     independent of board size.+--   * __INV6 (NoThunks).__ A long replay over a strict map yields a fully forced+--     board (no thunk tower), by construction.+--   * __FR6 (symbolic translation).__ Option B is modeled as a /named, queryable/+--     @SymStatus@: a collection guard yields @SkippedCollectionGuard "PMember"@+--     (honest and inspectable), a scalar guard yields @Verified@ — never a silent+--     free Boolean that the single-valuedness gate would trust blindly.+--+-- The accompanying written analysis (FR6 A-vs-B decision, Seihou reconciliation,+-- INV1–INV6 satisfiability argument) lives in the EP-60 plan,+-- @docs\/plans\/60-first-class-collection-registers-design-gated.md@.+module Keiki.CollectionSpike (spec) where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+-- Real keiki, used only to demonstrate the scalar path is untouched (INV5).+import Keiki.Core (RegFile (..), Term (TLit), evalTerm)+import Test.Hspec++-- ---------------------------------------------------------------------------+-- The BlockerBoard domain (the §6 worked example, in miniature)+-- ---------------------------------------------------------------------------++type BlockerId = Int++data Status = Open | Resolved | Escalated+  deriving (Eq, Show)++-- | An element record. FR1 wants the element type expressible as a sub-record+-- so its fields are projectable by FR4's 'TLookupField'; here that is an+-- ordinary record with two fields.+data BlockerState = BlockerState+  { bsStatus :: !Status,+    bsSeverity :: !Int+  }+  deriving (Eq, Show)++type Board = Map BlockerId BlockerState++-- | The command sum (@ci@ in keiki terms). Positional rather than record-style+-- so @severity@ is not a partial field (it exists only on 'AddBlocker').+data Cmd+  = AddBlocker BlockerId Int+  | ResolveBlocker BlockerId+  | EscalateBlocker BlockerId+  deriving (Eq, Show)++-- | The blocker id every command carries (total).+cId :: Cmd -> BlockerId+cId (AddBlocker i _) = i+cId (ResolveBlocker i) = i+cId (EscalateBlocker i) = i++-- | The severity field, present only on 'AddBlocker'. Read only by the+-- @AddBlocker@ edge's term, which fires only on an @AddBlocker@ command —+-- mirroring how keiki's 'Keiki.Core.TInpCtorField' read is guarded by the+-- edge's 'InCtor' match.+cSeverity :: Cmd -> Int+cSeverity (AddBlocker _ s) = s+cSeverity c = error ("cSeverity: not an AddBlocker: " ++ show c)++-- ---------------------------------------------------------------------------+-- FR1/FR2/FR4: a local model of the structural term + update vocabulary+-- ---------------------------------------------------------------------------++-- | A miniature of keiki's 'Keiki.Core.Term', restricted to the four+-- recoverability classes that matter to @solveOutput@\/@stepOne@. Concrete at+-- @ci ~ Cmd@ for the spike.+--+-- The first three constructors are /structural/ — an analysis can read them. The+-- last, 'KClosure', is the opaque @TApp@ escape hatch the collection feature+-- exists to /avoid/ for element operations; it appears here only as the negative+-- contrast in the zero-@TApp@ and recoverability tests.+data KTerm a where+  -- | @TLit@: a constant. Structural, carries no command information.+  KLit :: a -> KTerm a+  -- | @TInpCtorField@: read a named field of the command. Structural and+  --     /on the wire/ (recoverable from the emitted event when it carries it).+  KInpField :: String -> (Cmd -> a) -> KTerm a+  -- | @TLookupField@ (FR4): read field @field@ of the collection element at+  --     @key@. The @(BlockerState -> a)@ stands for the structural element-field+  --     @Index velems f@ (a record selector, not an opaque command transform).+  --     Structural and recoverable from the /replayed register file/ — it joins+  --     @TReg@, not @TApp@.+  KLookup :: String -> KTerm BlockerId -> String -> (BlockerState -> a) -> KTerm a+  -- | @TApp1@\/@TApp2@: opaque closure over the command. Analysis-blind.+  KClosure :: String -> (Cmd -> a) -> KTerm a++-- | Evaluate a 'KTerm' forward against the current board and command — the+-- spike's analogue of 'Keiki.Core.evalTerm'.+evalK :: Board -> Cmd -> KTerm a -> a+evalK _ _ (KLit a) = a+evalK _ ci (KInpField _ f) = f ci+evalK b ci (KLookup _ keyT _ proj) = proj (b Map.! evalK b ci keyT)+evalK _ ci (KClosure _ f) = f ci++-- | FR2 structural update combinators, carrying /terms/ not closures. The+-- element value of 'CInsert' is itself a structural record-builder ('ElemBuild')+-- so the whole insert is closure-free.+data CUpdate+  = CInsert (KTerm BlockerId) ElemBuild+  | CDelete (KTerm BlockerId)+  | CAdjust (KTerm BlockerId) ElemUpd++-- | A structural builder for a 'BlockerState' element from per-field terms+-- (FR1's "element as sub-record"): no opaque function assembles the record.+data ElemBuild = BuildBlocker (KTerm Status) (KTerm Int)++-- | A structural update of one element field (the @sub \@"status" .= t@ form).+newtype ElemUpd = SetStatus (KTerm Status)++evalElem :: Board -> Cmd -> ElemBuild -> BlockerState+evalElem b ci (BuildBlocker st sv) = BlockerState (evalK b ci st) (evalK b ci sv)++-- | Run a structural collection update /forward/ — the spike's analogue of+-- 'Keiki.Core.runUpdate'. This is what makes replay derived (INV1): no+-- hand-written @apply@, just forward re-evaluation of a structural update.+runCUpdate :: Board -> Cmd -> CUpdate -> Board+runCUpdate b ci (CInsert keyT elemB) =+  Map.insert (evalK b ci keyT) (evalElem b ci elemB) b+runCUpdate b ci (CDelete keyT) =+  Map.delete (evalK b ci keyT) b+runCUpdate b ci (CAdjust keyT (SetStatus st)) =+  Map.adjust (\e -> e {bsStatus = evalK b ci st}) (evalK b ci keyT) b++-- ---------------------------------------------------------------------------+-- FR3: structural content guards+-- ---------------------------------------------------------------------------++-- | FR3 collection-content predicates, plus a 'PScalar' stand-in for any+-- ordinary scalar guard (@PEq@\/@PCmp@) that the symbolic layer already handles.+data CPred+  = PMemberC (KTerm BlockerId)+  | PNotMemberC (KTerm BlockerId)+  | PAllC ElemPred+  | PScalar Bool++-- | A bounded element predicate (the body of a @PAll@\/@PAny@).+data ElemPred = StatusIs Status | StatusNot Status++matchElem :: ElemPred -> BlockerState -> Bool+matchElem (StatusIs s) e = bsStatus e == s+matchElem (StatusNot s) e = bsStatus e /= s++evalCPred :: Board -> Cmd -> CPred -> Bool+evalCPred b ci (PMemberC keyT) = Map.member (evalK b ci keyT) b+evalCPred b ci (PNotMemberC keyT) = not (Map.member (evalK b ci keyT) b)+evalCPred b _ (PAllC ep) = all (matchElem ep) (Map.elems b)+evalCPred _ _ (PScalar v) = v++-- ---------------------------------------------------------------------------+-- The BlockerBoard program — authored with ZERO closures+-- ---------------------------------------------------------------------------++-- | One guarded edge: a guard and a structural collection update.+data Edge = Edge {eGuard :: CPred, eUpdate :: CUpdate}++keyOf :: KTerm BlockerId+keyOf = KInpField "id" cId++-- | The BlockerBoard transducer, as a command-dispatched guarded program.+-- Every guard and update is built from structural constructors only — there is+-- not a single 'KClosure' in this definition, which the zero-@TApp@ test checks+-- mechanically.+--+--   * @AddBlocker@: requires the id is /not/ already present, inserts a fresh+--     @Open@ blocker carrying the command's severity.+--   * @ResolveBlocker@ \/ @EscalateBlocker@: require the id /is/ present, adjust+--     that one element's status.+program :: Cmd -> Edge+program (AddBlocker _ _) =+  Edge+    { eGuard = PNotMemberC keyOf,+      eUpdate = CInsert keyOf (BuildBlocker (KLit Open) (KInpField "severity" cSeverity))+    }+program (ResolveBlocker _) =+  Edge {eGuard = PMemberC keyOf, eUpdate = CAdjust keyOf (SetStatus (KLit Resolved))}+program (EscalateBlocker _) =+  Edge {eGuard = PMemberC keyOf, eUpdate = CAdjust keyOf (SetStatus (KLit Escalated))}++-- | "Cannot close the board while any blocker is unresolved" — the lifecycle+-- guard, a @PAll@ over the elements.+closeBoardGuard :: CPred+closeBoardGuard = PAllC (StatusNot Open)++-- | Apply one command through its guarded edge, if the guard holds; otherwise+-- leave the board unchanged (the spike's analogue of @step@ rejecting a+-- command). This is the derived replay step — no hand-written @apply@ (INV1).+stepBoard :: Board -> Cmd -> Board+stepBoard b ci =+  let Edge g u = program ci+   in if evalCPred b ci g then runCUpdate b ci u else b++reconstitute :: [Cmd] -> Board+reconstitute = foldl' stepBoard Map.empty++-- ---------------------------------------------------------------------------+-- Zero-TApp structural walkers+-- ---------------------------------------------------------------------------++termHasClosure :: KTerm a -> Bool+termHasClosure (KLit _) = False+termHasClosure (KInpField _ _) = False+termHasClosure (KLookup _ keyT _ _) = termHasClosure keyT+termHasClosure (KClosure _ _) = True++elemBuildHasClosure :: ElemBuild -> Bool+elemBuildHasClosure (BuildBlocker st sv) = termHasClosure st || termHasClosure sv++updateHasClosure :: CUpdate -> Bool+updateHasClosure (CInsert keyT e) = termHasClosure keyT || elemBuildHasClosure e+updateHasClosure (CDelete keyT) = termHasClosure keyT+updateHasClosure (CAdjust keyT (SetStatus st)) = termHasClosure keyT || termHasClosure st++predHasClosure :: CPred -> Bool+predHasClosure (PMemberC keyT) = termHasClosure keyT+predHasClosure (PNotMemberC keyT) = termHasClosure keyT+predHasClosure (PAllC _) = False+predHasClosure (PScalar _) = False++edgeHasClosure :: Edge -> Bool+edgeHasClosure (Edge g u) = predHasClosure g || updateHasClosure u++-- ---------------------------------------------------------------------------+-- INV2: a model of stepOne's recoverability classification+-- ---------------------------------------------------------------------------++-- | How @solveOutput@\/@stepOne@ treats an output field. Mirrors the verified+-- arms of @stepOne@ in @src\/Keiki\/Core.hs@ (lines ~1349–1359), where every arm+-- returns @Just …@ (never @Nothing@) but the /kind/ of recovery differs:+--+--   * 'FromWire' — @TInpCtorField@: contributes a recovered command slot.+--   * 'FromRegisters' — @TLit@\/@TReg@\/@TLookupField@: @Just []@, deterministically+--     reproducible from the replayed register file. __TLookupField joins here__+--     (INV2): the analysis can see exactly what it reads.+--   * 'OpaqueRecompute' — @TApp1@\/@TApp2@: @Just []@ too, but recompute-and-verify+--     (EP-47) — the closure is analysis-blind. A collection op must never land+--     here.+data Recoverability = FromWire | FromRegisters | OpaqueRecompute+  deriving (Eq, Show)++classify :: KTerm a -> Recoverability+classify (KLit _) = FromRegisters+classify (KInpField _ _) = FromWire+classify (KLookup {}) = FromRegisters+classify (KClosure _ _) = OpaqueRecompute++-- | The @stepOne@ result shape: the recovered command slots (here just slot+-- names). Crucially never @Nothing@ for these arms — a structural lookup does+-- not break the gather the way an opaque term returning @Nothing@ would.+stepOneSlots :: KTerm a -> Maybe [String]+stepOneSlots (KLit _) = Just []+stepOneSlots (KInpField name _) = Just [name]+stepOneSlots (KLookup {}) = Just []+stepOneSlots (KClosure _ _) = Just []++-- ---------------------------------------------------------------------------+-- INV3: a model of checkHiddenInputs over collection updates+-- ---------------------------------------------------------------------------++-- | Does this term read the command (@TInpCtorField@ anywhere)? Mirrors+-- @termReadsInput@ in @src\/Keiki\/Core.hs@.+termReadsInputK :: KTerm a -> Bool+termReadsInputK (KLit _) = False+termReadsInputK (KInpField _ _) = True+termReadsInputK (KLookup _ keyT _ _) = termReadsInputK keyT+termReadsInputK (KClosure _ _) = False++elemBuildReadsInput :: ElemBuild -> Bool+elemBuildReadsInput (BuildBlocker st sv) = termReadsInputK st || termReadsInputK sv++-- | The collection-update extension INV3 asks for: @updateReadsInput@ taught to+-- recurse into the new constructors. A @CInsert@\/@CAdjust@ whose key or element+-- data comes from the command reads the input.+collUpdateReadsInput :: CUpdate -> Bool+collUpdateReadsInput (CInsert keyT e) = termReadsInputK keyT || elemBuildReadsInput e+collUpdateReadsInput (CDelete keyT) = termReadsInputK keyT+collUpdateReadsInput (CAdjust keyT (SetStatus st)) = termReadsInputK keyT || termReadsInputK st++-- | The command-field names a collection update consumes (for coverage).+updateReadSlots :: CUpdate -> [String]+updateReadSlots (CInsert keyT e) = termSlots keyT ++ elemSlots e+updateReadSlots (CDelete keyT) = termSlots keyT+updateReadSlots (CAdjust keyT (SetStatus st)) = termSlots keyT ++ termSlots st++termSlots :: KTerm a -> [String]+termSlots (KLit _) = []+termSlots (KInpField name _) = [name]+termSlots (KLookup _ keyT _ _) = termSlots keyT+termSlots (KClosure _ _) = []++elemSlots :: ElemBuild -> [String]+elemSlots (BuildBlocker st sv) = termSlots st ++ termSlots sv++-- | A miniature of @checkHiddenInputs@ for a single edge. @wireSlots@ is the+-- union of command-field names recovered across the edge's emitted events. The+-- edge is flagged (result 'True') when its update reads the input but that input+-- is not fully covered on the wire — exactly the union-coverage rule, including+-- the ε-edge (empty @wireSlots@) case where any input-reading update is flagged.+checkHiddenEdge :: [String] -> CUpdate -> Bool+checkHiddenEdge wireSlots u =+  collUpdateReadsInput u && not (all (`elem` wireSlots) (updateReadSlots u))++-- ---------------------------------------------------------------------------+-- FR6: Option B — a named, queryable symbolic status+-- ---------------------------------------------------------------------------++-- | The Option B contract: instead of a guard silently becoming an opaque+-- @SBV.free@ Boolean (today's behavior, which a caller /cannot distinguish/ from a+-- real verification), a collection guard yields a named, inspectable status. The+-- scalar part of every aggregate keeps full verification.+--+-- (Option A would instead translate @PMember@\/@PSizeCmp@ to z3 array\/finite-set+-- theory and @PAll@\/@PAny@ to quantifiers — higher value, but the quantifiers+-- risk making the single-valuedness check undecidable\/slow. The Seihou cases need+-- only membership\/emptiness, so Option B is sufficient for the committed+-- consumer; a later EP can upgrade specific forms to Option A.)+data SymStatus = Verified | SkippedCollectionGuard String+  deriving (Eq, Show)++translateOptionB :: CPred -> SymStatus+translateOptionB (PScalar _) = Verified+translateOptionB (PMemberC _) = SkippedCollectionGuard "PMember"+translateOptionB (PNotMemberC _) = SkippedCollectionGuard "PNotMember"+translateOptionB (PAllC _) = SkippedCollectionGuard "PAll"++-- ---------------------------------------------------------------------------+-- INV4: static output arity — output length is a function of the command only+-- ---------------------------------------------------------------------------++-- | The (fixed) number of events each edge emits. Independent of the board, so+-- output arity is static (INV4). A collection mutation is a register update,+-- never a source of per-element output multiplicity.+outputArity :: Cmd -> Int+outputArity (AddBlocker _ _) = 1+outputArity (ResolveBlocker _) = 1+outputArity (EscalateBlocker _) = 1++-- ---------------------------------------------------------------------------+-- The spec+-- ---------------------------------------------------------------------------++-- A finite enumeration of command sequences (the suite is hspec-only; no+-- QuickCheck — see the EP-60 Surprises).+seqs :: [[Cmd]]+seqs =+  [ [],+    [AddBlocker 1 5],+    [AddBlocker 1 5, AddBlocker 2 3],+    [AddBlocker 1 5, ResolveBlocker 1],+    [AddBlocker 1 5, AddBlocker 1 9], -- second Add rejected (already member)+    [ResolveBlocker 7], -- rejected (not a member)+    [AddBlocker 1 5, AddBlocker 2 3, EscalateBlocker 2, ResolveBlocker 1],+    [AddBlocker 1 1, AddBlocker 2 2, AddBlocker 3 3, ResolveBlocker 2, EscalateBlocker 3]+  ]++-- | A reference semantics computed independently of the structural-update+-- machinery, to check INV1's derived replay against (a hand-written oracle used+-- ONLY in the test, never in the library path).+reference :: [Cmd] -> Board+reference = foldl' apply Map.empty+  where+    apply b (AddBlocker i sev)+      | Map.member i b = b+      | otherwise = Map.insert i (BlockerState Open sev) b+    apply b (ResolveBlocker i)+      | Map.member i b = Map.adjust (\e -> e {bsStatus = Resolved}) i b+      | otherwise = b+    apply b (EscalateBlocker i)+      | Map.member i b = Map.adjust (\e -> e {bsStatus = Escalated}) i b+      | otherwise = b++-- | The three edge shapes, one per command constructor.+allCmds :: [Cmd]+allCmds = [AddBlocker 1 5, ResolveBlocker 1, EscalateBlocker 1]++spec :: Spec+spec = do+  describe "FR1/FR2/FR4 — zero-TApp authoring (the headline acceptance)" $ do+    it "the entire BlockerBoard program contains no opaque closure" $+      any (edgeHasClosure . program) allCmds `shouldBe` False+    it "the close-board lifecycle guard (PAll) contains no closure" $+      predHasClosure closeBoardGuard `shouldBe` False++  describe "INV1 — derived replay reconstitutes the correct Map" $+    it "structural forward replay matches the reference oracle on every sequence" $+      map reconstitute seqs `shouldBe` map reference seqs++  describe "INV2 — solveOutput invertibility: TLookupField joins the structural side" $ do+    let priorSeverity = KLookup "blockers" keyOf "severity" bsSeverity+    it "TLookupField classifies as register-recoverable, like a literal read" $ do+      classify priorSeverity `shouldBe` FromRegisters+      classify (KLit (0 :: Int)) `shouldBe` FromRegisters+    it "an opaque closure is the contrasting NON-structural class" $+      classify (KClosure "sz" (const (0 :: Int))) `shouldBe` OpaqueRecompute+    it "a TLookupField output field never breaks the gather (Just, like TReg)" $+      stepOneSlots priorSeverity `shouldBe` Just []+    it "an on-wire input field contributes its recovered slot" $+      stepOneSlots (KInpField "severity" cSeverity) `shouldBe` Just ["severity"]++  describe "INV3 — checkHiddenInputs understands collection updates" $ do+    let addUpd = eUpdate (program (AddBlocker 1 5))+    it "an insert whose element data IS on the wire is clean" $+      checkHiddenEdge ["id", "severity"] addUpd `shouldBe` False+    it "a silent ε-edge insert (no output) whose data reads the input is FLAGGED" $+      checkHiddenEdge [] addUpd `shouldBe` True+    it "an insert that recovers id but NOT severity is flagged (partial coverage)" $+      checkHiddenEdge ["id"] addUpd `shouldBe` True+    it "a delete that only reads the key is clean once the key is on the wire" $+      checkHiddenEdge ["id"] (CDelete keyOf) `shouldBe` False++  describe "INV4 — static output arity (no per-element multiplicity)" $+    it "every edge emits a fixed number of events independent of the board" $+      map outputArity allCmds `shouldBe` [1, 1, 1]++  describe "INV6 — NoThunks: long replay over a strict map yields a forced board" $+    it "reconstituting 2000 commands forces fully (size computable, no bottom)" $ do+      let cmds = [AddBlocker i (i `mod` 7) | i <- [1 .. 2000]]+          b = reconstitute cmds+      Map.size b `shouldBe` 2000+      -- force every element to WHNF; a thunk tower would leak here+      sum (map bsSeverity (Map.elems b)) `shouldBe` sum [i `mod` 7 | i <- [1 .. 2000]]++  describe "FR6 — Option B: honest, queryable symbolic status" $ do+    it "a scalar guard is fully Verified" $+      translateOptionB (PScalar True) `shouldBe` Verified+    it "a PMember collection guard yields a NAMED, queryable skipped status" $+      translateOptionB (PMemberC keyOf) `shouldBe` SkippedCollectionGuard "PMember"+    it "the PAll lifecycle guard is skipped-but-named, never a silent free Bool" $+      translateOptionB closeBoardGuard `shouldBe` SkippedCollectionGuard "PAll"+    it "collection-guarded edges report unverified; the statuses are inspectable" $+      map (translateOptionB . eGuard . program) allCmds+        `shouldBe` [ SkippedCollectionGuard "PNotMember",+                     SkippedCollectionGuard "PMember",+                     SkippedCollectionGuard "PMember"+                   ]++  describe "INV5 — the scalar core path is untouched (real keiki still works)" $+    it "a scalar keiki Term evaluates exactly as before" $+      evalTerm (TLit 42 :: Term '[] () '[] Int) RNil () `shouldBe` 42
+ test/Keiki/CompositionAlternativeSpec.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Acceptance tests for 'Keiki.Composition.alternative' under EP-25+-- of MasterPlan 8. The fixture composes 'Keiki.Fixtures.EmailDelivery'+-- with a small inline 'Pinger' aggregate via 'alternative':+--+--    Either EmailCmd PingCmd  →  Either EmailEvent PingEvent+--+-- The two aggregates have disjoint slot-name domains+-- (EmailDelivery: @emailRecipient@, @emailSubject@, @emailSentAt@;+-- Pinger: @pingNonce@), so the @Disjoint (Names rs1) (Names rs2)@+-- constraint on 'alternative' resolves automatically.+--+-- The composite vertex is 'Composite' EmailVertex PingVertex+-- (product, not sum): each input updates exactly one sub-aggregate+-- and leaves the other's state unchanged. See EP-25's Surprises &+-- Discoveries entry dated 2026-05-03 for the design discovery that+-- led to this shape.+module Keiki.CompositionAlternativeSpec+  ( spec,+    -- Re-exported for "Keiki.Render.MermaidSpec" (EP-33 M6). Following+    -- the test-fixture-re-export pattern EP-31's M4 established (see+    -- @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@'s+    -- IP-5 reference).+    pinger,+    PingVertex (..),+    siblings,+  )+where++import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+import GHC.Generics (Generic)+import Keiki.Composition (Composite (..), alternative)+import Keiki.Core+import Keiki.Fixtures.EmailDelivery+import Keiki.Generics (Append, emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveWireCtors)+import Keiki.Symbolic (isSingleValuedSym, withSymPred)+import Test.Hspec++-- * The Pinger fixture ----------------------------------------------------++-- | Single-field command payload: the nonce echoed back as the+-- event's nonce.+data PingData = PingData+  { nonce :: Text+  }+  deriving stock (Eq, Show, Generic)++data PingCmd = Ping PingData+  deriving stock (Eq, Show, Generic)++-- | Single-field event payload: same nonce, different wrapping.+data PongData = PongData+  { nonce :: Text+  }+  deriving stock (Eq, Show, Generic)++data PingEvent = Pong PongData+  deriving stock (Eq, Show, Generic)++-- | Two-vertex aggregate: idle → pinged on a 'Ping'.+data PingVertex = PingIdle | PingDone+  deriving stock (Eq, Show, Enum, Bounded)++-- | Disjoint slot name from EmailDelivery's @emailRecipient@ /+-- @emailSubject@ / @emailSentAt@ so 'alternative''s+-- @Disjoint (Names rs1) (Names rs2)@ constraint resolves.+type PingRegs =+  '[ '("pingNonce", Text)+   ]++emptyPingRegs :: RegFile PingRegs+emptyPingRegs = emptyRegFile++-- TH-derived per-constructor projections + guards. The third element+-- (the binding-suffix) is "Ping" so the bindings are @inCtorPing@,+-- @inpPing@, @isPing@.+$( deriveAggregateCtors+     ''PingCmd+     ''PingRegs+     [ ("Ping", "Ping")+     ]+ )++$( deriveWireCtors+     ''PingEvent+     [ ("Pong", "Pong")+     ]+ )++pinger ::+  SymTransducer+    (HsPred PingRegs PingCmd)+    PingRegs+    PingVertex+    PingCmd+    PingEvent+pinger =+  SymTransducer+    { edgesOut = pingerEdges,+      initial = PingIdle,+      initialRegs = emptyPingRegs,+      isFinal = \case PingDone -> True; _ -> False+    }++pingerEdges ::+  PingVertex ->+  [Edge (HsPred PingRegs PingCmd) PingRegs PingCmd PingEvent PingVertex]+pingerEdges = \case+  PingIdle ->+    [ Edge+        { guard = isPing,+          update =+            USet+              (#pingNonce :: IndexN "pingNonce" PingRegs Text)+              (inpPing #nonce),+          output =+            [ pack+                inCtorPing+                wirePong+                (OFCons (inpPing #nonce) OFNil)+            ],+          target = PingDone+        }+    ]+  PingDone -> []++-- * The composite --------------------------------------------------------++-- | The alternative composite: emailDelivery on the left arm, pinger+-- on the right arm. The composite's vertex is the product+-- 'Composite EmailVertex PingVertex' — each arm has its own state+-- that evolves independently as Left / Right inputs arrive.+--+-- Input:  Either EmailCmd PingCmd+-- Output: Either EmailEvent PingEvent+-- Vertex: Composite EmailVertex PingVertex+-- Regs:   Append EmailRegs PingRegs+siblings ::+  SymTransducer+    (HsPred (Append EmailRegs PingRegs) (Either EmailCmd PingCmd))+    (Append EmailRegs PingRegs)+    (Composite EmailVertex PingVertex)+    (Either EmailCmd PingCmd)+    (Either EmailEvent PingEvent)+siblings = alternative emailDelivery pinger++-- * Test fixtures --------------------------------------------------------++sampleAt :: UTCTime+sampleAt = UTCTime (fromGregorian 2026 5 3) (secondsToDiffTime 36000)++sampleSendEmail :: EmailCmd+sampleSendEmail =+  SendEmail+    ( SendEmailData+        { recipient = "alice@example.com",+          subject = "Hello",+          at = sampleAt+        }+    )++sampleEmailEvent :: EmailEvent+sampleEmailEvent =+  EmailSent+    ( EmailSentData+        { recipient = "alice@example.com",+          subject = "Hello",+          at = sampleAt+        }+    )++samplePing :: PingCmd+samplePing = Ping (PingData {nonce = "abc123"})++samplePingEvent :: PingEvent+samplePingEvent = Pong (PongData {nonce = "abc123"})++-- * Specs ----------------------------------------------------------------++spec :: Spec+spec = do+  describe "alternative emailDelivery pinger" $ do+    describe "step routing" $ do+      it "Left input advances the EmailDelivery arm and emits Left output" $+        case step+          siblings+          (initial siblings, initialRegs siblings)+          (Left sampleSendEmail) of+          Just (Composite ev pv, _, [Left co]) -> do+            ev `shouldBe` EmailSentVertex+            pv `shouldBe` PingIdle -- Pinger arm unchanged+            co `shouldBe` sampleEmailEvent+          other ->+            expectationFailure+              ( "expected Just (Composite EmailSentVertex PingIdle, _, Just (Left EmailSent ...)), got "+                  <> showStep other+              )++      it "Right input advances the Pinger arm and emits Right output" $+        case step+          siblings+          (initial siblings, initialRegs siblings)+          (Right samplePing) of+          Just (Composite ev pv, _, [Right co]) -> do+            ev `shouldBe` EmailPending -- EmailDelivery arm unchanged+            pv `shouldBe` PingDone+            co `shouldBe` samplePingEvent+          other ->+            expectationFailure+              ( "expected Just (Composite EmailPending PingDone, _, Just (Right Pong ...)), got "+                  <> showStep other+              )++      it "two-step interleave: Left then Right advances both arms independently" $+        case step+          siblings+          (initial siblings, initialRegs siblings)+          (Left sampleSendEmail) of+          Just (s1, regs1, _) ->+            case step siblings (s1, regs1) (Right samplePing) of+              Just (Composite ev pv, _, [Right co]) -> do+                ev `shouldBe` EmailSentVertex -- preserved from step 1+                pv `shouldBe` PingDone+                co `shouldBe` samplePingEvent+              other ->+                expectationFailure+                  ( "expected both arms advanced after Left+Right, got "+                      <> showStep other+                  )+          Nothing -> expectationFailure "first step (Left) returned Nothing"++    describe "checkHiddenInputs" $ do+      it "reports no warnings on the alternative composite" $+        checkHiddenInputs siblings `shouldBe` []++    describe "isSingleValuedSym (symbolic)" $ do+      it "the alternative composite is single-valued" $+        isSingleValuedSym (withSymPred siblings) `shouldBe` True++    describe "reconstitute (mixed-arm event log replay)" $ do+      it "lands at Composite EmailSentVertex PingDone on a Left+Right log" $+        case reconstitute siblings [Left sampleEmailEvent, Right samplePingEvent] of+          Just (Composite ev pv, _) -> do+            ev `shouldBe` EmailSentVertex+            pv `shouldBe` PingDone+          Nothing ->+            expectationFailure+              "reconstitute returned Nothing on the canonical mixed-arm log"++      it "preserves cross-arm state across reconstitute order (Right then Left)" $+        case reconstitute siblings [Right samplePingEvent, Left sampleEmailEvent] of+          Just (Composite ev pv, _) -> do+            ev `shouldBe` EmailSentVertex+            pv `shouldBe` PingDone+          Nothing ->+            expectationFailure+              "reconstitute returned Nothing on the reordered mixed-arm log"++    describe "omega (the wire event for one external command)" $ do+      it "produces Left sampleEmailEvent on Left sampleSendEmail" $+        omega+          siblings+          (initial siblings)+          (initialRegs siblings)+          (Left sampleSendEmail)+          `shouldBe` [(Left sampleEmailEvent)]++      it "produces Right samplePingEvent on Right samplePing" $+        omega+          siblings+          (initial siblings)+          (initialRegs siblings)+          (Right samplePing)+          `shouldBe` [(Right samplePingEvent)]+  where+    showStep ::+      Maybe+        ( Composite EmailVertex PingVertex,+          x,+          [Either EmailEvent PingEvent]+        ) ->+      String+    showStep Nothing = "Nothing"+    showStep (Just (cs, _, cos_)) =+      "Just (" <> show cs <> ", _, " <> show cos_ <> ")"
+ test/Keiki/CompositionFeedback1Spec.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Acceptance tests for 'Keiki.Composition.feedback1' under EP-26+-- of MasterPlan 8. The fixture is a tiny aggregate ↔ policy loop:+--+--    ToggleAgg ↔ TogglePolicy+--+-- The aggregate is a two-vertex toggle (Off/On) whose only command+-- 'TgFlip' alternates the vertex and emits a 'TgFlipped' event+-- carrying the same 'tValue' the command supplied. The policy is a+-- stateless one-vertex echo: on every observed 'TgFlipped' event it+-- emits another 'TgFlip' command, forwarding the value field.+--+-- The composite is @feedback1 toggleAgg togglePolicy@. Per the+-- design record at+-- @docs/research/composition-combinators-design.md@'s "`feedback1` —+-- admitted (single-step reduction)" section, this is implemented as+-- @compose t (compose f t)@: t consumes the external command, f+-- maps the resulting event back to a follow-up command, and a+-- second copy of t consumes that follow-up.+--+-- Both halves have empty register files (@'[]@). This is required+-- by 'feedback1''s+-- @Disjoint (Names rs1) (Names (Append rs2 rs1))@ constraint —+-- only @rs1 = '[]@ satisfies it (see EP-26's Decision Log entry+-- dated 2026-05-03). The aggregate's state lives entirely in the+-- vertex.+--+-- The cascade is observable from the composite vertex: after one+-- external command from the initial vertex+-- @Composite Off (Composite Pol Off)@, the composite advances to+-- @Composite On (Composite Pol On)@ — both the outer and the inner+-- copies of t have transitioned, proving the policy's emitted+-- command was consumed by the second t. The output's 'tValue' is+-- the original input's 'tValue', forwarded through the cascade by+-- structural substitution.+module Keiki.CompositionFeedback1Spec+  ( spec,+    -- Re-exported for "Keiki.Render.MermaidSpec" (EP-33 M6). See+    -- @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@'s+    -- IP-5 reference.+    toggleAgg,+    togglePolicy,+    ToggleVertex (..),+    PolicyVertex (..),+    loop,+  )+where++import GHC.Generics (Generic)+import Keiki.Composition (Composite (..), feedback1)+import Keiki.Core+import Keiki.Generics (Append, emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveWireCtors)+import Keiki.Symbolic (isSingleValuedSym, withSymPred)+import Test.Hspec++-- * The Toggle aggregate fixture (stateless) ------------------------------++-- | Single-field payload carried by both the command and event.+-- Forwarded verbatim through every cascade hop, so the composite's+-- final 'TgFlipped' value matches the original 'TgFlip' value.+data TgPayload = TgPayload+  { tValue :: Int+  }+  deriving stock (Eq, Show, Generic)++-- | Single-constructor command type with a record payload (the+-- shape 'deriveAggregateCtors' / 'deriveWireCtors' expect).+data TgCmd = TgFlip TgPayload+  deriving stock (Eq, Show, Generic)++-- | Single-constructor event type with the same record payload.+data TgEv = TgFlipped TgPayload+  deriving stock (Eq, Show, Generic)++-- | Two-vertex toggle: each TgFlip command alternates Off ↔ On.+data ToggleVertex = Off | On+  deriving stock (Eq, Show, Enum, Bounded)++-- | Aggregate has no register slots; the toggle's state is entirely+-- in the vertex.+type ToggleRegs = '[]++-- TH-derived per-constructor projections / guards / wire ctors for+-- the aggregate side. Binding suffixes pick "Flip" / "Flipped" to+-- keep call sites readable.+$( deriveAggregateCtors+     ''TgCmd+     ''ToggleRegs+     [ ("TgFlip", "Flip")+     ]+ )++$( deriveWireCtors+     ''TgEv+     [ ("TgFlipped", "Flipped")+     ]+ )++toggleAgg ::+  SymTransducer+    (HsPred ToggleRegs TgCmd)+    ToggleRegs+    ToggleVertex+    TgCmd+    TgEv+toggleAgg =+  SymTransducer+    { edgesOut = toggleEdges,+      initial = Off,+      initialRegs = emptyRegFile,+      isFinal = const True+    }++toggleEdges ::+  ToggleVertex ->+  [Edge (HsPred ToggleRegs TgCmd) ToggleRegs TgCmd TgEv ToggleVertex]+toggleEdges = \case+  Off ->+    [ Edge+        { guard = isFlip,+          update = UKeep,+          output =+            [ pack+                inCtorFlip+                wireFlipped+                (OFCons (inpFlip #tValue) OFNil)+            ],+          target = On+        }+    ]+  On ->+    [ Edge+        { guard = isFlip,+          update = UKeep,+          output =+            [ pack+                inCtorFlip+                wireFlipped+                (OFCons (inpFlip #tValue) OFNil)+            ],+          target = Off+        }+    ]++-- * The Policy fixture (stateless) ----------------------------------------++-- | Single-vertex policy: on every TgFlipped event, emit another+-- TgFlip command with the same value. This is the "stateless+-- reactor" pattern from the orchestration design note.+data PolicyVertex = Pol+  deriving stock (Eq, Show, Enum, Bounded)++type PolicyRegs = '[]++-- TH-derived guards / wire ctors for the policy side. Distinct+-- binding suffixes ("PFlipped", "PFlip") avoid clashing with the+-- aggregate-side bindings above. The underlying constructor names+-- ("TgFlipped", "TgFlip") still match across the aggregate ↔ policy+-- boundary, so 'compose''s structural-name substitution wires the+-- cascade correctly.+$( deriveAggregateCtors+     ''TgEv+     ''PolicyRegs+     [ ("TgFlipped", "PFlipped")+     ]+ )++$( deriveWireCtors+     ''TgCmd+     [ ("TgFlip", "PFlip")+     ]+ )++togglePolicy ::+  SymTransducer+    (HsPred PolicyRegs TgEv)+    PolicyRegs+    PolicyVertex+    TgEv+    TgCmd+togglePolicy =+  SymTransducer+    { edgesOut = policyEdges,+      initial = Pol,+      initialRegs = emptyRegFile,+      isFinal = const True+    }++policyEdges ::+  PolicyVertex ->+  [Edge (HsPred PolicyRegs TgEv) PolicyRegs TgEv TgCmd PolicyVertex]+policyEdges = \case+  Pol ->+    [ Edge+        { guard = isPFlipped,+          update = UKeep,+          output =+            [ pack+                inCtorPFlipped+                wirePFlip+                (OFCons (inpPFlipped #tValue) OFNil)+            ],+          target = Pol+        }+    ]++-- * The composite --------------------------------------------------------++-- | The single-step feedback composite.+--+-- Vertex: @Composite ToggleVertex (Composite PolicyVertex ToggleVertex)@.+--   Read as "outer toggle, then (policy, inner toggle)". Both+--   toggles are independent copies (the implementation+--   @compose t (compose f t)@ does not share register state across+--   the two t copies — they evolve in parallel within one composite+--   step).+-- Regs:   @Append '[] (Append '[] '[])@ ≡ '[].+-- Input:  TgCmd+-- Output: TgEv+loop ::+  SymTransducer+    (HsPred (Append ToggleRegs (Append PolicyRegs ToggleRegs)) TgCmd)+    (Append ToggleRegs (Append PolicyRegs ToggleRegs))+    (Composite ToggleVertex (Composite PolicyVertex ToggleVertex))+    TgCmd+    TgEv+loop = feedback1 toggleAgg togglePolicy++-- * Test fixtures --------------------------------------------------------++externalCmd :: TgCmd+externalCmd = TgFlip (TgPayload {tValue = 42})++cascadedEvent :: TgEv+cascadedEvent = TgFlipped (TgPayload {tValue = 42})++-- * Specs ---------------------------------------------------------------++spec :: Spec+spec = do+  describe "feedback1 toggleAgg togglePolicy" $ do+    describe "single-step cascade" $ do+      it "Composite Off (Composite Pol Off) -- TgFlip{42} --> Composite On (Composite Pol On), emitting TgFlipped{42}" $+        case step loop (initial loop, initialRegs loop) externalCmd of+          Just (Composite outerT (Composite policy innerT), _, [co]) -> do+            outerT `shouldBe` On -- outer toggle stepped Off → On+            policy `shouldBe` Pol -- policy self-loops+            innerT `shouldBe` On -- inner toggle stepped Off → On (proves cascade ran)+            co `shouldBe` cascadedEvent+          other ->+            expectationFailure+              ( "expected Just (Composite On (Composite Pol On), _, [TgFlipped{42}]), got "+                  <> showStep other+              )++      it "two consecutive composite steps return to the initial vertex" $+        case step loop (initial loop, initialRegs loop) externalCmd of+          Just (s1, regs1, _) ->+            case step loop (s1, regs1) externalCmd of+              Just (Composite outerT (Composite policy innerT), _, [co]) -> do+                outerT `shouldBe` Off -- back to initial+                policy `shouldBe` Pol+                innerT `shouldBe` Off+                co `shouldBe` cascadedEvent+              other ->+                expectationFailure+                  ( "expected Composite Off (Composite Pol Off) after 2 steps, got "+                      <> showStep other+                  )+          Nothing -> expectationFailure "first step returned Nothing"++    describe "round-trip replay" $ do+      it "reconstitute on [cascadedEvent] lands at Composite On (Composite Pol On)" $+        case reconstitute loop [cascadedEvent] of+          Just (Composite outerT (Composite policy innerT), _) -> do+            outerT `shouldBe` On+            policy `shouldBe` Pol+            innerT `shouldBe` On+          Nothing ->+            expectationFailure+              "reconstitute returned Nothing for the canonical one-event log"++      it "reconstitute on [cascadedEvent, cascadedEvent] returns to the initial vertex" $+        case reconstitute loop [cascadedEvent, cascadedEvent] of+          Just (Composite outerT (Composite policy innerT), _) -> do+            outerT `shouldBe` Off+            policy `shouldBe` Pol+            innerT `shouldBe` Off+          Nothing ->+            expectationFailure+              "reconstitute returned Nothing for the two-event log"++    describe "checkHiddenInputs" $ do+      it "reports no warnings on the feedback1 composite" $+        checkHiddenInputs loop `shouldBe` []++    describe "isSingleValuedSym (symbolic)" $ do+      it "the feedback1 composite is single-valued" $+        isSingleValuedSym (withSymPred loop) `shouldBe` True++    describe "omega (the wire event for one external command)" $ do+      it "produces cascadedEvent on externalCmd from the initial composite state" $+        omega loop (initial loop) (initialRegs loop) externalCmd+          `shouldBe` [cascadedEvent]+  where+    showStep ::+      Maybe+        ( Composite ToggleVertex (Composite PolicyVertex ToggleVertex),+          x,+          [TgEv]+        ) ->+      String+    showStep Nothing = "Nothing"+    showStep (Just (cs, _, cos_)) =+      "Just (" <> show cs <> ", _, " <> show cos_ <> ")"
+ test/Keiki/CompositionMultiEventSpec.hs view
@@ -0,0 +1,220 @@+-- | EP-19 M6 acceptance: 'Keiki.Composition.compose' on a multi-event+-- first-edge produces a length-N composite edge via library-side+-- chain expansion. The fixture is intentionally minimal: t1 has one+-- vertex (Q) with a self-loop edge emitting two mid-symbols; t2 has+-- one vertex (Z) with a self-loop edge that consumes any mid and+-- emits one wire event. The composite's single edge from Composite+-- Q Z therefore has output of length 2.+module Keiki.CompositionMultiEventSpec (spec) where++import Data.Proxy (Proxy (..))+import Keiki.Composition (Composite (..), compose)+import Keiki.Core+import Test.Hspec++-- * t1 ---------------------------------------------------------------------++-- | t1's input alphabet: a single trigger constructor carrying an Int payload.+data T1Cmd = T1Trigger Int deriving (Eq, Show)++inCtorT1Trigger :: InCtor T1Cmd '[ '("payload", Int)]+inCtorT1Trigger =+  InCtor+    { icName = "T1Trigger",+      icMatch = \case+        T1Trigger n -> Just (RCons (Proxy @"payload") n RNil),+      icBuild = \(RCons _ n RNil) -> T1Trigger n+    }++-- | t1's mid (output) alphabet: two constructors A and B.+data Mid = MidA Int | MidB Int deriving (Eq, Show)++inCtorMidA :: InCtor Mid '[ '("a", Int)]+inCtorMidA =+  InCtor+    { icName = "MidA",+      icMatch = \case+        MidA n -> Just (RCons (Proxy @"a") n RNil)+        _ -> Nothing,+      icBuild = \(RCons _ n RNil) -> MidA n+    }++inCtorMidB :: InCtor Mid '[ '("b", Int)]+inCtorMidB =+  InCtor+    { icName = "MidB",+      icMatch = \case+        MidB n -> Just (RCons (Proxy @"b") n RNil)+        _ -> Nothing,+      icBuild = \(RCons _ n RNil) -> MidB n+    }++wcMidA :: WireCtor Mid (Int, ())+wcMidA =+  WireCtor+    { wcName = "MidA",+      wcMatch = \case+        MidA n -> Just (n, ())+        _ -> Nothing,+      wcBuild = \(n, ()) -> MidA n+    }++wcMidB :: WireCtor Mid (Int, ())+wcMidB =+  WireCtor+    { wcName = "MidB",+      wcMatch = \case+        MidB n -> Just (n, ())+        _ -> Nothing,+      wcBuild = \(n, ()) -> MidB n+    }++-- | t1's transducer: a single vertex Q with a self-loop edge that+-- emits two mid-symbols ([MidA n, MidB n]) from one T1Trigger input.+data Q = Q deriving (Eq, Show, Bounded, Enum)++t1 :: SymTransducer (HsPred '[] T1Cmd) '[] Q T1Cmd Mid+t1 =+  SymTransducer+    { edgesOut = \Q ->+        [ Edge+            { guard = matchInCtor inCtorT1Trigger,+              update = UKeep,+              output =+                [ pack+                    inCtorT1Trigger+                    wcMidA+                    ( OFCons+                        ( TInpCtorField+                            inCtorT1Trigger+                            (#payload :: Index '[ '("payload", Int)] Int)+                        )+                        OFNil+                    ),+                  pack+                    inCtorT1Trigger+                    wcMidB+                    ( OFCons+                        ( TInpCtorField+                            inCtorT1Trigger+                            (#payload :: Index '[ '("payload", Int)] Int)+                        )+                        OFNil+                    )+                ],+              target = Q+            }+        ],+      initial = Q,+      initialRegs = RNil,+      isFinal = const True+    }++-- * t2 ---------------------------------------------------------------------++-- | t2's output alphabet: one constructor.+data Echo = EchoA Int | EchoB Int deriving (Eq, Show)++wcEchoA :: WireCtor Echo (Int, ())+wcEchoA =+  WireCtor+    { wcName = "EchoA",+      wcMatch = \case+        EchoA n -> Just (n, ())+        _ -> Nothing,+      wcBuild = \(n, ()) -> EchoA n+    }++wcEchoB :: WireCtor Echo (Int, ())+wcEchoB =+  WireCtor+    { wcName = "EchoB",+      wcMatch = \case+        EchoB n -> Just (n, ())+        _ -> Nothing,+      wcBuild = \(n, ()) -> EchoB n+    }++-- | t2's vertex (single).+data Z = Z deriving (Eq, Show, Bounded, Enum)++-- | t2's transducer: two edges from Z, one per mid-symbol.+--   Z on MidA → Z / [EchoA payload]+--   Z on MidB → Z / [EchoB payload]+t2 :: SymTransducer (HsPred '[] Mid) '[] Z Mid Echo+t2 =+  SymTransducer+    { edgesOut = \Z ->+        [ Edge+            { guard = matchInCtor inCtorMidA,+              update = UKeep,+              output =+                [ pack+                    inCtorMidA+                    wcEchoA+                    ( OFCons+                        ( TInpCtorField+                            inCtorMidA+                            (#a :: Index '[ '("a", Int)] Int)+                        )+                        OFNil+                    )+                ],+              target = Z+            },+          Edge+            { guard = matchInCtor inCtorMidB,+              update = UKeep,+              output =+                [ pack+                    inCtorMidB+                    wcEchoB+                    ( OFCons+                        ( TInpCtorField+                            inCtorMidB+                            (#b :: Index '[ '("b", Int)] Int)+                        )+                        OFNil+                    )+                ],+              target = Z+            }+        ],+      initial = Z,+      initialRegs = RNil,+      isFinal = const True+    }++-- * Specs ------------------------------------------------------------------++spec :: Spec+spec = do+  describe "compose t1 t2 with t1 having one length-2 edge" $ do+    it "every composite edge from (Q, Z) has a length-2 output list" $ do+      -- The chain expansion produces one composite edge per t2-edge+      -- choice per mid-symbol — 2 mid-symbols × 2 t2-edges = 4+      -- composite edges. Three of the four have unsatisfiable+      -- substituted guards (`substPred (PInCtor MidA) MidB ≡ PBot`),+      -- but they're structurally present. All four have a length-2+      -- output list — the chain expansion concatenates per-step+      -- substituted outputs.+      let pipeline = compose t1 t2+          edges = edgesOut pipeline (initial pipeline)+      length edges `shouldBe` 4+      mapM_ (\e -> length (output e) `shouldBe` 2) edges++    it "omega on T1Trigger 42 yields [EchoA 42, EchoB 42]" $ do+      let pipeline = compose t1 t2+      omega pipeline (initial pipeline) (initialRegs pipeline) (T1Trigger 42)+        `shouldBe` [EchoA 42, EchoB 42]++    it "applyEvents round-trips the 2-event chunk to the initial composite state" $ do+      let pipeline = compose t1 t2+          chunk = [EchoA 7, EchoB 7]+      case applyEvents pipeline (initial pipeline, initialRegs pipeline) chunk of+        Just (Composite Q Z, _) -> pure ()+        other ->+          expectationFailure+            ( "expected Just (Composite Q Z, _), got "+                <> show (fmap (\(s, _) -> s) other)+            )
+ test/Keiki/CompositionNarySpec.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TemplateHaskell #-}++-- | EP-48: N-ary event-family codec composition and singleton events.+--+-- Three groups:+--+--   1. /Multi-family round-trip/ — sum three independently-derived+--      families into one alphabet via the arity-3 injectors, build an+--      edge output in family 1 and in family 2, and assert 'solveOutput'+--      inverts the summed event back to the (injected) command.+--   2. /Name uniqueness/ — the injected constructor names are pairwise+--      distinct (the precondition 'solveOutput' relies on, since it+--      matches by @icName@/@wcName@ string equality), and a colliding+--      alphabet is caught by the same check.+--   3. /Singleton events/ — 'deriveWireCtors' now derives a zero-arg+--      event 'WireCtor', and 'solveOutput' inverts a singleton event to+--      its singleton command.+module Keiki.CompositionNarySpec (spec) where++import Data.List (nub)+import Data.Maybe (isNothing)+import GHC.Generics (Generic)+import Keiki.Composition+  ( inCtor3At1,+    inCtor3At2,+    inCtor3At3,+    outTerm3At1,+    outTerm3At2,+    wireCtor3At1,+    wireCtor3At2,+    wireCtor3At3,+  )+import Keiki.Core+  ( InCtor (..),+    OutFields (..),+    OutTerm,+    RegFile (..),+    WireCtor (..),+    pack,+    solveOutput,+  )+import Keiki.Generics (FieldsOf, RegFieldsOf, mkWireCtor0)+import Keiki.Generics.TH (deriveAggregateCtors, deriveWireCtors)+import Test.Hspec++-- * Three independent event families ------------------------------------++-- None of these aggregates use registers, so the register schema is+-- empty; the output fields read from the input command, not from state.+type Regs = '[]++-- Family 1 (A): a record-payload command/event pair.+data AData = AData {aVal :: Int} deriving (Eq, Show, Generic)++data ACmd = AFlip AData deriving (Eq, Show, Generic)++data AEvt = AFlipped AData deriving (Eq, Show, Generic)++-- Family 2 (B).+data BData = BData {bVal :: Int} deriving (Eq, Show, Generic)++data BCmd = BFlip BData deriving (Eq, Show, Generic)++data BEvt = BFlipped BData deriving (Eq, Show, Generic)++-- Family 3 (C) — present so the 3-way sum is concrete and so the+-- uniqueness check has a third name to compare.+data CData = CData {cVal :: Int} deriving (Eq, Show, Generic)++data CCmd = CFlip CData deriving (Eq, Show, Generic)++data CEvt = CFlipped CData deriving (Eq, Show, Generic)++$(deriveAggregateCtors ''ACmd ''Regs [("AFlip", "AFlip")])+$(deriveWireCtors ''AEvt [("AFlipped", "AFlipped")])+$(deriveAggregateCtors ''BCmd ''Regs [("BFlip", "BFlip")])+$(deriveWireCtors ''BEvt [("BFlipped", "BFlipped")])+$(deriveAggregateCtors ''CCmd ''Regs [("CFlip", "CFlip")])+$(deriveWireCtors ''CEvt [("CFlipped", "CFlipped")])++-- The right-nested 3-family summed alphabets.+type SumCmd = Either ACmd (Either BCmd CCmd)++type SumEvt = Either AEvt (Either BEvt CEvt)++-- Edge output terms re-homed into the summed alphabet, one per family.+sumOutA :: OutTerm Regs SumCmd SumEvt+sumOutA = outTerm3At1 (pack inCtorAFlip wireAFlipped (OFCons (inpAFlip #aVal) OFNil))++sumOutB :: OutTerm Regs SumCmd SumEvt+sumOutB = outTerm3At2 (pack inCtorBFlip wireBFlipped (OFCons (inpBFlip #bVal) OFNil))++-- Injected wire/in constructors, used by the uniqueness group.+sumWireA :: WireCtor SumEvt (FieldsOf AData)+sumWireA = wireCtor3At1 wireAFlipped++sumWireB :: WireCtor SumEvt (FieldsOf BData)+sumWireB = wireCtor3At2 wireBFlipped++sumWireC :: WireCtor SumEvt (FieldsOf CData)+sumWireC = wireCtor3At3 wireCFlipped++sumInA :: InCtor SumCmd (RegFieldsOf AData)+sumInA = inCtor3At1 inCtorAFlip++sumInB :: InCtor SumCmd (RegFieldsOf BData)+sumInB = inCtor3At2 inCtorBFlip++sumInC :: InCtor SumCmd (RegFieldsOf CData)+sumInC = inCtor3At3 inCtorCFlip++-- * A singleton (payload-free) event family -----------------------------++data DoorCmd = OpenDoor | CloseDoor deriving (Eq, Show, Generic)++data DoorEvt = DoorOpened | DoorClosed deriving (Eq, Show, Generic)++$( deriveAggregateCtors+     ''DoorCmd+     ''Regs+     [("OpenDoor", "OpenDoor"), ("CloseDoor", "CloseDoor")]+ )++-- This is the new capability: deriveWireCtors over zero-arg event ctors.+$( deriveWireCtors+     ''DoorEvt+     [("DoorOpened", "DoorOpened"), ("DoorClosed", "DoorClosed")]+ )++spec :: Spec+spec = do+  describe "summing N event families" $ do+    it "round-trips a family-1 event through solveOutput" $+      solveOutput sumOutA RNil (Left (AFlipped (AData 5)))+        `shouldBe` Just (Left (AFlip (AData 5)))++    it "round-trips a family-2 event through solveOutput" $+      solveOutput sumOutB RNil (Right (Left (BFlipped (BData 7))))+        `shouldBe` Just (Right (Left (BFlip (BData 7))))++    it "rejects an event from the wrong family arm" $+      -- sumOutA inverts only family-1 (Left) events; a family-2 value+      -- does not match its WireCtor, so inversion yields Nothing.+      solveOutput sumOutA RNil (Right (Left (BFlipped (BData 7))))+        `shouldBe` Nothing++  describe "icName/wcName uniqueness" $ do+    -- solveOutput/stepOne match by name string (src/Keiki/Core.hs ~1067),+    -- so the summed families' constructor names must be pairwise distinct.+    it "injected family names are pairwise distinct" $ do+      let wcNames = [wcName sumWireA, wcName sumWireB, wcName sumWireC]+          icNames = [icName sumInA, icName sumInB, icName sumInC]+      (length wcNames, length (nub wcNames)) `shouldBe` (3, 3)+      (length icNames, length (nub icNames)) `shouldBe` (3, 3)++    it "a colliding alphabet is caught by the uniqueness check" $ do+      -- Two distinct families that both name a ctor "Dup": were they+      -- summed, solveOutput's name-equality match could mis-invert. The+      -- nub-based uniqueness check flags the collision.+      let collidingNames =+            [ wcName (mkWireCtor0 "Dup" () :: WireCtor () ()),+              wcName (mkWireCtor0 "Dup" 'x' :: WireCtor Char ())+            ]+      (length collidingNames == length (nub collidingNames)) `shouldBe` False++  describe "singleton events" $ do+    it "deriveWireCtors derives a zero-arg event WireCtor" $ do+      wcName wireDoorOpened `shouldBe` "DoorOpened"+      wcMatch wireDoorOpened DoorOpened `shouldBe` Just ()+      isNothing (wcMatch wireDoorOpened DoorClosed) `shouldBe` True+      wcBuild wireDoorOpened () `shouldBe` DoorOpened++    it "solveOutput inverts a singleton event to its singleton command" $+      solveOutput (pack inCtorOpenDoor wireDoorOpened OFNil) RNil DoorOpened+        `shouldBe` Just OpenDoor
+ test/Keiki/CompositionSpec.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Acceptance tests for 'Keiki.Composition.compose' under EP-11 of+-- MasterPlan 4. The fixture is a tiny pipeline:+--+--    AlertSource ⨾ EmailDelivery+--+-- Aggregate 1 ('AlertSource', defined inline in this spec) is a+-- two-vertex transducer that consumes a 'TriggerAlert' command and+-- emits an 'EmailCmd' as its event. Its output type is exactly+-- 'EmailCmd' so that the composite's @mid@ alphabet aligns with+-- 'Keiki.Fixtures.EmailDelivery''s input alphabet without an+-- explicit lifting.+--+-- Aggregate 2 is the canonical 'Keiki.Fixtures.EmailDelivery'+-- transducer.+--+-- The pipeline shape — every transition produces a wire event —+-- means the composite's 'reconstitute' round-trip is well-defined+-- (the design note discusses the ε-edge restriction).+module Keiki.CompositionSpec+  ( spec,+    -- Exported for re-use in 'Keiki.Render.MermaidSpec' (EP-31 M4).+    -- See the Decision Log of+    -- @docs/plans/31-mermaid-rendering-for-composite-symtransducers.md@+    -- for why we re-export rather than duplicate the fixture.+    alertSource,+    AlertVertex (..),+  )+where++import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+import GHC.Generics (Generic)+import Keiki.Composition (Composite (..), compose)+import Keiki.Core+import Keiki.Fixtures.EmailDelivery+import Keiki.Generics (Append, emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveWireCtors)+import Keiki.Symbolic (isSingleValuedSym, withSymPred)+import Test.Hspec++-- * The AlertSource test fixture ------------------------------------------++-- | Command payload for the source aggregate. Carries the full set+-- of fields the composite ultimately writes into 'EmailEvent', so+-- the round-trip can verify each field arrives intact.+data TriggerAlertData = TriggerAlertData+  { recipient :: Text,+    subject :: Text,+    at :: UTCTime+  }+  deriving stock (Eq, Show, Generic)++-- | Command sum for the source aggregate.+data AlertCmd = TriggerAlert TriggerAlertData+  deriving stock (Eq, Show, Generic)++-- | The source aggregate's *output* type is EmailCmd — so the+-- composite's mid alphabet aligns with EmailDelivery's input.+type AlertEvent = EmailCmd++-- | Register file for the source aggregate. Mirrors EmailRegs in+-- field shape but with distinct slot names so 'Append AlertRegs+-- EmailRegs' has no name collisions (the keiki RegFile is+-- positional, but distinct names also keep the SBV translation's+-- free-variable names unambiguous).+type AlertRegs =+  '[ '("alertRecipient", Text),+     '("alertSubject", Text),+     '("alertAt", UTCTime)+   ]++data AlertVertex = AlertQuiescent | AlertEmitted+  deriving stock (Eq, Show, Enum, Bounded)++emptyAlertRegs :: RegFile AlertRegs+emptyAlertRegs = emptyRegFile++-- TH-derived per-constructor projections + guards.+$( deriveAggregateCtors+     ''AlertCmd+     ''AlertRegs+     [ ("TriggerAlert", "Trigger")+     ]+ )++-- The output of AlertSource is EmailCmd — reuse the wire+-- constructor TH splice over EmailCmd by piggy-backing on+-- EmailDelivery's @SendEmail@ data ctor. We can't @deriveWireCtors@+-- against 'EmailCmd' here because that would conflict with+-- EmailDelivery's TH splice's binding of @wireSendEmail@. Build+-- the wire ctor manually using the same generic shape.+$( deriveWireCtors+     ''EmailCmd+     [ ("SendEmail", "SendEmailEvent")+     ]+ )++alertSource ::+  SymTransducer+    (HsPred AlertRegs AlertCmd)+    AlertRegs+    AlertVertex+    AlertCmd+    EmailCmd+alertSource =+  SymTransducer+    { edgesOut = alertEdges,+      initial = AlertQuiescent,+      initialRegs = emptyAlertRegs,+      isFinal = \case AlertEmitted -> True; _ -> False+    }++alertEdges ::+  AlertVertex ->+  [Edge (HsPred AlertRegs AlertCmd) AlertRegs AlertCmd EmailCmd AlertVertex]+alertEdges = \case+  AlertQuiescent ->+    [ Edge+        { guard = isTrigger,+          update =+            USet+              (#alertRecipient :: IndexN "alertRecipient" AlertRegs Text)+              (inpTrigger #recipient)+              `combine` USet+                (#alertSubject :: IndexN "alertSubject" AlertRegs Text)+                (inpTrigger #subject)+              `combine` USet+                (#alertAt :: IndexN "alertAt" AlertRegs UTCTime)+                (inpTrigger #at),+          -- The output is EmailCmd — built from the trigger's payload.+          output =+            [ pack+                inCtorTrigger+                wireSendEmailEvent+                ( OFCons+                    (inpTrigger #recipient)+                    ( OFCons+                        (inpTrigger #subject)+                        (OFCons (inpTrigger #at) OFNil)+                    )+                )+            ],+          target = AlertEmitted+        }+    ]+  AlertEmitted -> []++-- * The composite ---------------------------------------------------------++-- | The composite pipeline: AlertSource ⨾ EmailDelivery.+--+-- Input:  AlertCmd+-- Output: EmailEvent+-- Vertex: Composite AlertVertex EmailVertex+-- Regs:   Append AlertRegs EmailRegs+pipeline ::+  SymTransducer+    (HsPred (Append AlertRegs EmailRegs) AlertCmd)+    (Append AlertRegs EmailRegs)+    (Composite AlertVertex EmailVertex)+    AlertCmd+    EmailEvent+pipeline = compose alertSource emailDelivery++-- * Test fixtures ---------------------------------------------------------++sampleAt :: UTCTime+sampleAt = UTCTime (fromGregorian 2026 5 2) (secondsToDiffTime 36000)++sampleTrigger :: AlertCmd+sampleTrigger =+  TriggerAlert+    ( TriggerAlertData+        { recipient = "alice@example.com",+          subject = "Hello",+          at = sampleAt+        }+    )++sampleEmailEvent :: EmailEvent+sampleEmailEvent =+  EmailSent+    ( EmailSentData+        { recipient = "alice@example.com",+          subject = "Hello",+          at = sampleAt+        }+    )++-- * Specs -----------------------------------------------------------------++spec :: Spec+spec = do+  describe "compose alertSource emailDelivery" $ do+    describe "step (one external command in, one wire event out)" $ do+      it "produces EmailSent on TriggerAlert" $+        case step pipeline (initial pipeline, initialRegs pipeline) sampleTrigger of+          Just (Composite av ev, _, [co]) -> do+            av `shouldBe` AlertEmitted+            ev `shouldBe` EmailSentVertex+            co `shouldBe` sampleEmailEvent+          other ->+            expectationFailure+              ( "expected Just (Composite AlertEmitted EmailSentVertex, _, Just EmailSent ...), got "+                  <> showStep other+              )++      it "rejects TriggerAlert at the terminal composite vertex" $+        let terminalState = Composite AlertEmitted EmailSentVertex+         in case step pipeline (terminalState, initialRegs pipeline) sampleTrigger of+              Nothing -> pure ()+              other -> expectationFailure ("expected Nothing, got " <> showStep other)++    describe "checkHiddenInputs" $ do+      it "reports no warnings on the composite" $+        checkHiddenInputs pipeline `shouldBe` []++    describe "isSingleValuedSym (symbolic)" $ do+      it "the composite is single-valued" $+        isSingleValuedSym (withSymPred pipeline) `shouldBe` True++    describe "reconstitute (multi-aggregate event log replay)" $ do+      it "lands at the expected final composite state" $+        case reconstitute pipeline [sampleEmailEvent] of+          Just (Composite av ev, _) -> do+            av `shouldBe` AlertEmitted+            ev `shouldBe` EmailSentVertex+          Nothing ->+            expectationFailure "reconstitute returned Nothing for the canonical event log"++    describe "omega (the wire event for one external command)" $ do+      it "produces sampleEmailEvent on TriggerAlert from initial state" $+        omega pipeline (initial pipeline) (initialRegs pipeline) sampleTrigger+          `shouldBe` [sampleEmailEvent]+  where+    showStep :: Maybe (Composite AlertVertex EmailVertex, x, [EmailEvent]) -> String+    showStep Nothing = "Nothing"+    showStep (Just (Composite a b, _, cos_)) =+      "Just (Composite " <> show a <> " " <> show b <> ", _, " <> show cos_ <> ")"
+ test/Keiki/CoreApplyEventsSpec.hs view
@@ -0,0 +1,72 @@+module Keiki.CoreApplyEventsSpec (spec) where++import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import Keiki.Core (applyEvents, initial, initialRegs, (!))+import Keiki.Fixtures.UserRegistration+import Test.Hspec++-- | A trivial UTC-time fixture matching 'UserRegistrationSpec's+-- convention: every test moment is on the same day, offset by N+-- seconds.+t :: Integer -> UTCTime+t s = UTCTime (fromGregorian 2026 5 1) (secondsToDiffTime s)++-- | The synthesis §4 canonical event log, identical to the one+-- exercised by 'Keiki.Fixtures.UserRegistrationSpec'. Reproduced+-- here so the spec is self-contained.+canonicalLog :: [UserEvent]+canonicalLog =+  [ RegistrationStarted (RegistrationStartedData "alice@x" "Z9F4" (t 0)),+    ConfirmationEmailSent (ConfirmationEmailSentData "alice@x"),+    ConfirmationResent (ConfirmationResentData "alice@x" "K2P7" (t 100)),+    AccountConfirmed (AccountConfirmedData "alice@x" "K2P7" (t 200)),+    AccountDeleted (AccountDeletedData "alice@x" (t 300))+  ]++-- | The two events that 'StartRegistration' produces under state+-- refinement: the public emission and the synthetic 'Continue'-driven+-- emission. Together they take @PotentialCustomer@ to+-- @RequiresConfirmation@ via the intermediate @Registering@.+multiEventChunk :: [UserEvent]+multiEventChunk =+  [ RegistrationStarted (RegistrationStartedData "alice@x" "Z9F4" (t 0)),+    ConfirmationEmailSent (ConfirmationEmailSentData "alice@x")+  ]++spec :: Spec+spec = do+  describe "applyEvents folds applyEvent over a chunk" $ do+    it "round-trips the canonical 5-event log from the initial state" $+      case applyEvents userReg (initial userReg, initialRegs userReg) canonicalLog of+        Just (s, regs) ->+          (s, regs ! #email, regs ! #confirmCode)+            `shouldBe` (Deleted, "alice@x", "K2P7")+        Nothing -> expectationFailure "applyEvents returned Nothing"++    it "replays a 2-event chunk for one logical command from PotentialCustomer" $+      -- StartRegistration's two events: RegistrationStarted ++      -- ConfirmationEmailSent. Under state refinement the chunk passes+      -- through Registering and lands at RequiresConfirmation with the+      -- command's register writes applied.+      case applyEvents userReg (PotentialCustomer, emptyRegs) multiEventChunk of+        Just (s, regs) -> do+          s `shouldBe` RequiresConfirmation+          (regs ! #email, regs ! #confirmCode, regs ! #registeredAt)+            `shouldBe` ("alice@x", "Z9F4", t 0)+        Nothing -> expectationFailure "applyEvents returned Nothing"++    it "returns Nothing for an out-of-order event sequence" $+      -- ConfirmationEmailSent is not the prefix of any active edge's+      -- output at PotentialCustomer (the only outgoing letter edge+      -- emits RegistrationStarted). The fold short-circuits to+      -- Nothing. We pattern-match manually because 'RegFile+      -- UserRegRegs' has no 'Show' instance, so 'shouldBe' /+      -- 'shouldSatisfy' on the raw 'Maybe' do not type-check.+      case applyEvents+        userReg+        (PotentialCustomer, emptyRegs)+        [ConfirmationEmailSent (ConfirmationEmailSentData "alice@x")] of+        Nothing -> pure ()+        Just _ ->+          expectationFailure+            "applyEvents accepted an out-of-order event"
+ test/Keiki/CoreHiddenInputsGSMSpec.hs view
@@ -0,0 +1,184 @@+module Keiki.CoreHiddenInputsGSMSpec (spec) where++import Data.List (isInfixOf)+import Data.Proxy (Proxy (..))+import Keiki.Core+import Test.Hspec++-- | A 3-slot input constructor used to stress the union check.+data MultiInput = Begin Int Int Int deriving (Eq, Show)++data MultiOutput+  = OutAB Int Int -- recovers slots a, b+  | OutBC Int Int -- recovers slots b, c+  | OutA Int -- recovers slot a only+  deriving (Eq, Show)++inCtorBegin :: InCtor MultiInput '[ '("a", Int), '("b", Int), '("c", Int)]+inCtorBegin =+  InCtor+    { icName = "Begin",+      icMatch = \case+        Begin a b c ->+          Just $+            RCons (Proxy @"a") a $+              RCons (Proxy @"b") b $+                RCons (Proxy @"c") c $+                  RNil,+      icBuild = \(RCons _ a (RCons _ b (RCons _ c RNil))) -> Begin a b c+    }++wcAB :: WireCtor MultiOutput (Int, (Int, ()))+wcAB =+  WireCtor+    { wcName = "OutAB",+      wcMatch = \case+        OutAB a b -> Just (a, (b, ()))+        _ -> Nothing,+      wcBuild = \(a, (b, ())) -> OutAB a b+    }++wcBC :: WireCtor MultiOutput (Int, (Int, ()))+wcBC =+  WireCtor+    { wcName = "OutBC",+      wcMatch = \case+        OutBC b c -> Just (b, (c, ()))+        _ -> Nothing,+      wcBuild = \(b, (c, ())) -> OutBC b c+    }++wcA :: WireCtor MultiOutput (Int, ())+wcA =+  WireCtor+    { wcName = "OutA",+      wcMatch = \case+        OutA a -> Just (a, ())+        _ -> Nothing,+      wcBuild = \(a, ()) -> OutA a+    }++-- | The "well-formed" multi-event edge: two OPacks whose union of+-- visited slots covers all three of @Begin@'s slots.+-- OPack #1 (OutAB) visits {a, b}; OPack #2 (OutBC) visits {b, c}.+-- Union = {a, b, c} = full InCtor coverage. No warning expected.+goodUnion :: SymTransducer (HsPred '[] MultiInput) '[] Bool MultiInput MultiOutput+goodUnion =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = matchInCtor inCtorBegin,+                update = UKeep,+                output =+                  [ pack+                      inCtorBegin+                      wcAB+                      ( OFCons+                          (TInpCtorField inCtorBegin (#a :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int))+                          (OFCons (TInpCtorField inCtorBegin (#b :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int)) OFNil)+                      ),+                    pack+                      inCtorBegin+                      wcBC+                      ( OFCons+                          (TInpCtorField inCtorBegin (#b :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int))+                          (OFCons (TInpCtorField inCtorBegin (#c :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int)) OFNil)+                      )+                  ],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = id+    }++-- | The "ill-formed" multi-event edge: two OPacks whose union of+-- visited slots is {a, b}, leaving slot @c@ unrecovered. Both OPacks+-- name the same InCtor (@Begin@); the union check should flag @c@.+badUnion :: SymTransducer (HsPred '[] MultiInput) '[] Bool MultiInput MultiOutput+badUnion =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = matchInCtor inCtorBegin,+                update = UKeep,+                output =+                  [ pack+                      inCtorBegin+                      wcAB+                      ( OFCons+                          (TInpCtorField inCtorBegin (#a :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int))+                          (OFCons (TInpCtorField inCtorBegin (#b :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int)) OFNil)+                      ),+                    pack+                      inCtorBegin+                      wcA+                      (OFCons (TInpCtorField inCtorBegin (#a :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int)) OFNil)+                  ],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = id+    }++-- | A single-event edge that does NOT cover all slots of its InCtor.+-- Legacy behaviour: the per-OPack check fires. Confirms the union+-- check is a strict generalisation (not a regression) of the legacy+-- single-event check.+badSingle :: SymTransducer (HsPred '[] MultiInput) '[] Bool MultiInput MultiOutput+badSingle =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = matchInCtor inCtorBegin,+                update = UKeep,+                output =+                  [ pack+                      inCtorBegin+                      wcA+                      (OFCons (TInpCtorField inCtorBegin (#a :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int)) OFNil)+                  ],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = id+    }++spec :: Spec+spec = do+  describe "checkHiddenInputs union strengthening (EP-19 M4)" $ do+    it "well-formed multi-event edge (union covers all slots) ⇒ no warnings" $+      checkHiddenInputs goodUnion `shouldBe` []++    it "ill-formed multi-event edge (union still misses slot c) ⇒ warning names c" $ do+      let warnings = checkHiddenInputs badUnion+      length warnings `shouldBe` 1+      case warnings of+        [w] -> do+          hiwEdgeSource w `shouldBe` "False"+          hiwReason w `shouldSatisfy` ("Begin" `isInfixOf`)+          hiwReason w `shouldSatisfy` ("\"c\"" `isInfixOf`)+        _ -> expectationFailure "expected exactly one warning"++    it "single-event edge missing slots fires too (legacy compat)" $ do+      let warnings = checkHiddenInputs badSingle+      length warnings `shouldBe` 1+      case warnings of+        [w] -> do+          hiwEdgeSource w `shouldBe` "False"+          hiwReason w `shouldSatisfy` ("Begin" `isInfixOf`)+          -- Legacy behaviour: missing both b and c.+          hiwReason w `shouldSatisfy` ("\"b\"" `isInfixOf`)+          hiwReason w `shouldSatisfy` ("\"c\"" `isInfixOf`)+        _ -> expectationFailure "expected exactly one warning"
+ test/Keiki/CoreInFlightSpec.hs view
@@ -0,0 +1,148 @@+module Keiki.CoreInFlightSpec (spec) where++import Data.Proxy (Proxy (..))+import Keiki.Core+import Test.Hspec++-- | A synthetic 2-event command for one transition. The input has one+-- constructor; the output alphabet has two: 'Started' and 'Echoed'.+-- A single edge from 'False' to 'True' emits both, in that order.+data MultiInput = Begin Int deriving (Eq, Show)++data MultiOutput = Started Int | Echoed Int deriving (Eq, Show)++inCtorBegin :: InCtor MultiInput '[ '("payload", Int)]+inCtorBegin =+  InCtor+    { icName = "Begin",+      icMatch = \case+        Begin n -> Just (RCons (Proxy @"payload") n RNil),+      icBuild = \(RCons _ n RNil) -> Begin n+    }++wcStarted :: WireCtor MultiOutput (Int, ())+wcStarted =+  WireCtor+    { wcName = "Started",+      wcMatch = \case+        Started n -> Just (n, ())+        _ -> Nothing,+      wcBuild = \(n, ()) -> Started n+    }++wcEchoed :: WireCtor MultiOutput (Int, ())+wcEchoed =+  WireCtor+    { wcName = "Echoed",+      wcMatch = \case+        Echoed n -> Just (n, ())+        _ -> Nothing,+      wcBuild = \(n, ()) -> Echoed n+    }++-- | A minimal 2-vertex transducer with one length-2 edge:+--+--   False --[guard ci=Begin / output [Started n, Echoed n]]--> True+multi :: SymTransducer (HsPred '[] MultiInput) '[] Bool MultiInput MultiOutput+multi =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = matchInCtor inCtorBegin,+                update = UKeep,+                output =+                  [ pack+                      inCtorBegin+                      wcStarted+                      (OFCons (TInpCtorField inCtorBegin (#payload :: Index '[ '("payload", Int)] Int)) OFNil),+                    pack+                      inCtorBegin+                      wcEchoed+                      (OFCons (TInpCtorField inCtorBegin (#payload :: Index '[ '("payload", Int)] Int)) OFNil)+                  ],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = id+    }++spec :: Spec+spec = do+  describe "omega returns a length-2 event list for a multi-event edge" $ do+    it "Begin 42 yields [Started 42, Echoed 42]" $+      omega multi False RNil (Begin 42) `shouldBe` [Started 42, Echoed 42]++  describe "step's third component is the same length-2 list" $ do+    it "step (False, RNil) (Begin 7) returns (True, _, [Started 7, Echoed 7])" $+      case step multi (False, RNil) (Begin 7) of+        Just (True, _, [Started 7, Echoed 7]) -> pure ()+        other -> expectationFailure ("unexpected: " <> show3 other)++  describe "applyEvents (chunked replay)" $ do+    it "round-trips [Started 42, Echoed 42] from Settled False" $+      case applyEvents multi (False, RNil) [Started 42, Echoed 42] of+        Just (s, _) -> s `shouldBe` True+        Nothing -> expectationFailure "applyEvents returned Nothing"++    it "rejects a truncated chunk [Started 42] (queue non-empty at end)" $+      case applyEvents multi (False, RNil) [Started 42] of+        Nothing -> pure ()+        Just _ ->+          expectationFailure+            "applyEvents accepted a chunk that ends mid-flight"++    it "rejects an out-of-order chunk [Echoed 42, Started 42]" $+      case applyEvents multi (False, RNil) [Echoed 42, Started 42] of+        Nothing -> pure ()+        Just _ -> expectationFailure "applyEvents accepted out-of-order events"++  describe "applyEventStreaming (event-by-event)" $ do+    it "Settled False ⊢ Started 42 → InFlight True [Echoed 42]" $+      case applyEventStreaming multi (Settled False) RNil (Started 42) of+        Just (InFlight True [Echoed 42], _) -> pure ()+        other -> expectationFailure ("unexpected: " <> showInFlight other)++    it "InFlight True [Echoed 42] ⊢ Echoed 42 → Settled True" $+      case applyEventStreaming multi (InFlight True [Echoed 42]) RNil (Echoed 42) of+        Just (Settled True, _) -> pure ()+        other -> expectationFailure ("unexpected: " <> showInFlight other)++    it "Settled False ⊢ Echoed 42 → Nothing (out-of-order)" $+      case applyEventStreaming multi (Settled False) RNil (Echoed 42) of+        Nothing -> pure ()+        Just _ -> expectationFailure "accepted out-of-order first event"++    it "InFlight True [Echoed 42] ⊢ Started 42 → Nothing (queue mismatch)" $+      case applyEventStreaming multi (InFlight True [Echoed 42]) RNil (Started 42) of+        Nothing -> pure ()+        Just _ ->+          expectationFailure+            "applyEventStreaming accepted an out-of-order tail event"++  describe "streaming and chunked replay agree on the final state" $ do+    it "step-by-step InFlight threading reaches the same Settled True" $ do+      let chunked = applyEvents multi (False, RNil) [Started 42, Echoed 42]+          streamed = do+            (s1, regs1) <- applyEventStreaming multi (Settled False) RNil (Started 42)+            (s2, regs2) <- applyEventStreaming multi s1 regs1 (Echoed 42)+            case s2 of+              Settled v -> Just (v, regs2)+              _ -> Nothing+      case (chunked, streamed) of+        (Just (cs, _), Just (ss, _)) -> cs `shouldBe` ss+        _ ->+          expectationFailure+            "chunked and streaming replay disagreed on the final state"+  where+    show3 :: Maybe (Bool, x, [MultiOutput]) -> String+    show3 Nothing = "Nothing"+    show3 (Just (s, _, cos_)) =+      "Just (" <> show s <> ", _, " <> show cos_ <> ")"++    showInFlight :: Maybe (InFlight Bool MultiOutput, x) -> String+    showInFlight Nothing = "Nothing"+    showInFlight (Just (w, _)) = "Just (" <> show w <> ", _)"
+ test/Keiki/CoreSpec.hs view
@@ -0,0 +1,297 @@+module Keiki.CoreSpec (spec) where++import Control.Exception (evaluate)+import Data.Proxy (Proxy (..))+import Keiki.Core+import Test.Hspec++-- | A two-constructor input symbol used by the 'TInpCtorField' tests.+data TinyCmd = TinyFoo Int Int | TinyBar Int deriving (Eq, Show)++inCtorTinyFoo ::+  InCtor+    TinyCmd+    '[ '("a", Int), '("b", Int)]+inCtorTinyFoo =+  InCtor+    { icName = "TinyFoo",+      icMatch = \case+        TinyFoo a b ->+          Just+            ( RCons (Proxy @"a") a $+                RCons (Proxy @"b") b $+                  RNil+            )+        _ -> Nothing,+      icBuild = \(RCons _ a (RCons _ b RNil)) -> TinyFoo a b+    }++-- The synthetic transducer's input-side singleton: matches 'True' only,+-- with an empty payload. 'icName' aligns with the wire-side 'wcName'+-- so 'solveOutput' on the OPack walks an empty 'OutFields' against an+-- empty slot list and recovers 'True'.+inCtorTrue :: InCtor Bool '[]+inCtorTrue =+  InCtor+    { icName = "True",+      icMatch = \case+        True -> Just RNil+        False -> Nothing,+      icBuild = \RNil -> True+    }++-- The synthetic transducer's wire-side singleton: a one-constructor+-- 'WireCtor' over 'String' carrying no fields, recognising the literal+-- "true". Paired with 'inCtorTrue' under 'OPack' to give the synthetic+-- edge a structural output term (no opaque 'mkOut').+wcStringTrue :: WireCtor String ()+wcStringTrue =+  WireCtor+    { wcName = "True",+      wcMatch = \s -> if s == "true" then Just () else Nothing,+      wcBuild = \() -> "true"+    }++-- A minimal 2-vertex transducer over 'Bool' input, 'String' output, no+-- registers. Edges:+--+--   False --[guard ci=True / output \"true\"]--> True+--+-- This is the smallest example that exercises 'delta', 'omega', and+-- 'evalOut' on a real edge while keeping the type machinery simple.+synthetic :: SymTransducer (HsPred '[] Bool) '[] Bool Bool String+synthetic =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = matchInCtor inCtorTrue,+                update = UKeep,+                output = [pack inCtorTrue wcStringTrue OFNil],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = id+    }++spec :: Spec+spec = do+  describe "evalTerm" $ do+    it "evaluates TLit" $+      evalTerm (TLit (42 :: Int)) RNil () `shouldBe` 42+    it "evaluates TApp1" $+      evalTerm (TApp1 (+ 1) (TLit (5 :: Int)) :: Term '[] () '[] Int) RNil () `shouldBe` 6+    it "evaluates TApp2" $+      evalTerm+        (TApp2 (+) (TLit (5 :: Int)) (TLit 10) :: Term '[] () '[] Int)+        RNil+        ()+        `shouldBe` 15++  describe "TInpCtorField (structural input projection)" $ do+    it "evaluates field #a on the matching constructor" $+      evalTerm+        ( TInpCtorField inCtorTinyFoo (#a :: Index '[ '("a", Int), '("b", Int)] Int) ::+            Term '[] TinyCmd '[ '("a", Int), '("b", Int)] Int+        )+        RNil+        (TinyFoo 7 9)+        `shouldBe` 7+    it "evaluates field #b on the matching constructor" $+      evalTerm+        ( TInpCtorField inCtorTinyFoo (#b :: Index '[ '("a", Int), '("b", Int)] Int) ::+            Term '[] TinyCmd '[ '("a", Int), '("b", Int)] Int+        )+        RNil+        (TinyFoo 7 9)+        `shouldBe` 9+    it "errors with the icName when the input is the wrong constructor" $+      evaluate+        ( evalTerm+            ( TInpCtorField inCtorTinyFoo (#a :: Index '[ '("a", Int), '("b", Int)] Int) ::+                Term '[] TinyCmd '[ '("a", Int), '("b", Int)] Int+            )+            RNil+            (TinyBar 0)+        )+        `shouldThrow` errorCall "evalTerm: TInpCtorField guard violation: TinyFoo"+    it "termReadsInput is True for a TInpCtorField term" $+      termReadsInput+        ( TInpCtorField inCtorTinyFoo (#a :: Index '[ '("a", Int), '("b", Int)] Int) ::+            Term '[] TinyCmd '[ '("a", Int), '("b", Int)] Int+        )+        `shouldBe` True++  describe "evalPred" $ do+    it "PTop is True; PBot is False" $ do+      evalPred (PTop :: HsPred '[] ()) RNil () `shouldBe` True+      evalPred (PBot :: HsPred '[] ()) RNil () `shouldBe` False+    it "PEq compares equal terms" $+      evalPred (TLit (1 :: Int) .== TLit 1 :: HsPred '[] ()) RNil () `shouldBe` True++  describe "synthetic 2-vertex transducer" $ do+    it "delta moves False -> True on input True (state)" $+      fmap fst (delta synthetic False RNil True) `shouldBe` Just True+    it "omega emits \"true\" on the matching edge" $+      omega synthetic False RNil True `shouldBe` ["true"]+    it "delta returns Nothing when the guard is unsatisfied" $+      fmap fst (delta synthetic False RNil False) `shouldBe` Nothing+    it "delta returns Nothing in the True (sink) vertex" $+      fmap fst (delta synthetic True RNil True) `shouldBe` Nothing++  describe "step" $ do+    it "produces (s', _, Just co) on a matching output edge" $ do+      case step synthetic (False, RNil) True of+        Just (s', _, [co]) -> (s', co) `shouldBe` (True, "true")+        other -> expectationFailure (show3 other)+    it "returns Nothing in the sink vertex" $+      case step synthetic (True, RNil) True of+        Nothing -> pure ()+        other -> expectationFailure (show3 other)++  describe "reconstitute" $ do+    it "returns the initial state for the empty log" $+      case reconstitute synthetic ([] :: [String]) of+        Just (s, _) -> s `shouldBe` False+        Nothing -> expectationFailure "expected Just (initial, _)"++  describe "solveOutput structural path (TInpCtorField)" $ do+    let -- An output sum mirroring TinyCmd's payload (ci-determined wire).+        wireTinyFoo :: WireCtor TinyCmdOut (Int, (Int, ()))+        wireTinyFoo =+          WireCtor+            { wcName = "TinyFooOut",+              wcMatch = \(TinyFooOut a b) -> Just (a, (b, ())),+              wcBuild = \(a, (b, ())) -> TinyFooOut a b+            }+        -- Complete OPack: both fields read from inCtorTinyFoo.+        outComplete :: OutTerm '[] TinyCmd TinyCmdOut+        outComplete =+          OPack+            inCtorTinyFoo+            wireTinyFoo+            ( OFCons+                ( TInpCtorField+                    inCtorTinyFoo+                    (#a :: Index '[ '("a", Int), '("b", Int)] Int)+                )+                ( OFCons+                    ( TInpCtorField+                        inCtorTinyFoo+                        (#b :: Index '[ '("a", Int), '("b", Int)] Int)+                    )+                    OFNil+                )+            )+        -- Incomplete OPack: only #a is in OutFields; #b is a constant.+        outIncomplete :: OutTerm '[] TinyCmd TinyCmdOut+        outIncomplete =+          OPack+            inCtorTinyFoo+            wireTinyFoo+            ( OFCons+                ( TInpCtorField+                    inCtorTinyFoo+                    (#a :: Index '[ '("a", Int), '("b", Int)] Int)+                )+                (OFCons (TLit (0 :: Int)) OFNil)+            )+        -- EP-53: an InCtor with the SAME field schema as inCtorTinyFoo but+        -- a different icName. Because 'OutFields' is now indexed by the+        -- input field schema and 'OPack' ties it to the InCtor, a field+        -- projection whose *schema* differs from the OPack's InCtor is a+        -- compile error (un-representable) — the old runtime collision+        -- hazard is gone. The icName is retained only as a runtime+        -- diagnostic: a same-schema projection naming a different+        -- constructor is a clean replay failure ('Nothing'), never a+        -- type-unsound coercion.+        inCtorTinyFooOther :: InCtor TinyCmd '[ '("a", Int), '("b", Int)]+        inCtorTinyFooOther =+          InCtor+            { icName = "OtherName",+              icMatch = \case+                TinyFoo a b ->+                  Just+                    ( RCons (Proxy @"a") a $+                        RCons (Proxy @"b") b $+                          RNil+                    )+                _ -> Nothing,+              icBuild = \(RCons _ a (RCons _ b RNil)) -> TinyFoo a b+            }+        outNameMismatch :: OutTerm '[] TinyCmd TinyCmdOut+        outNameMismatch =+          OPack+            inCtorTinyFoo+            wireTinyFoo+            ( OFCons+                ( TInpCtorField+                    inCtorTinyFooOther+                    (#a :: Index '[ '("a", Int), '("b", Int)] Int)+                )+                ( OFCons+                    ( TInpCtorField+                        inCtorTinyFooOther+                        (#b :: Index '[ '("a", Int), '("b", Int)] Int)+                    )+                    OFNil+                )+            )++    it "evalOut produces TinyFooOut on a matching ci" $+      evalOut outComplete RNil (TinyFoo 7 11) `shouldBe` TinyFooOut 7 11+    it "solveOutput recovers ci structurally (no legacy inverse)" $+      solveOutput outComplete RNil (TinyFooOut 7 11) `shouldBe` Just (TinyFoo 7 11)+    it "solveOutput returns Nothing on incomplete coverage" $+      solveOutput outIncomplete RNil (TinyFooOut 7 0) `shouldBe` Nothing+    it "rejects a same-schema TInpCtorField whose icName differs (EP-53 diagnostic)" $+      solveOutput outNameMismatch RNil (TinyFooOut 7 11) `shouldBe` Nothing+    it "detectMissingInCtorFields names the missing slot" $+      let fs =+            OFCons+              ( TInpCtorField+                  inCtorTinyFoo+                  (#a :: Index '[ '("a", Int), '("b", Int)] Int)+              )+              (OFCons (TLit (0 :: Int)) OFNil) ::+              OutFields '[] TinyCmd '[ '("a", Int), '("b", Int)] (Int, (Int, ()))+       in detectMissingInCtorFields inCtorTinyFoo fs+            `shouldBe` Just (MissingInCtorFields "TinyFoo" ["b"])+    it "detectMissingInCtorFields is Nothing on complete coverage" $+      let fs =+            OFCons+              ( TInpCtorField+                  inCtorTinyFoo+                  (#a :: Index '[ '("a", Int), '("b", Int)] Int)+              )+              ( OFCons+                  ( TInpCtorField+                      inCtorTinyFoo+                      (#b :: Index '[ '("a", Int), '("b", Int)] Int)+                  )+                  OFNil+              ) ::+              OutFields '[] TinyCmd '[ '("a", Int), '("b", Int)] (Int, (Int, ()))+       in detectMissingInCtorFields inCtorTinyFoo fs `shouldBe` Nothing+    it "outFieldsHaveInpCtorField is True when at least one TInpCtorField appears" $+      let fs =+            OFCons+              ( TInpCtorField+                  inCtorTinyFoo+                  (#a :: Index '[ '("a", Int), '("b", Int)] Int)+              )+              OFNil ::+              OutFields '[] TinyCmd '[ '("a", Int), '("b", Int)] (Int, ())+       in outFieldsHaveInpCtorField fs `shouldBe` True+  where+    -- 'show' over `Maybe (s, RegFile rs, Maybe co)` is awkward because+    -- RegFile has no Show. Use a thin coercion to a printable summary.+    show3 :: (Show s) => (Show co) => Maybe (s, x, [co]) -> String+    show3 Nothing = "Nothing"+    show3 (Just (s, _, cos_)) = "Just (" ++ show s ++ ", _, " ++ show cos_ ++ ")"++-- | Output sum mirroring 'TinyCmd' for the M3 structural-path tests.+data TinyCmdOut = TinyFooOut Int Int deriving (Eq, Show)
+ test/Keiki/DeciderSpec.hs view
@@ -0,0 +1,152 @@+module Keiki.DeciderSpec (spec) where++import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import Keiki.Core+import Keiki.Decider+import Keiki.Fixtures.UserRegistration+import Test.Hspec++-- | Same time fixture as 'Keiki.Fixtures.UserRegistrationSpec' so the+-- decider round-trip lands on the snapshot 'reconstitute' produces.+t :: Integer -> UTCTime+t s = UTCTime (fromGregorian 2026 5 1) (secondsToDiffTime s)++type Snapshot = (Email, ConfirmationCode, UTCTime, UTCTime, UTCTime)++snapshot :: RegFile UserRegRegs -> Snapshot+snapshot regs =+  ( regs ! #email,+    regs ! #confirmCode,+    regs ! #registeredAt,+    regs ! #confirmedAt,+    regs ! #deletedAt+  )++-- | The forward command sequence whose 'omega' trace matches+-- 'Keiki.Fixtures.UserRegistrationSpec.canonicalLog'. The reconstitute+-- spec fixes the events; this fixture records the inputs that produce+-- them on the User Registration edge graph.+-- EP-19 M7: the entrance now drives PotentialCustomer →+-- RequiresConfirmation in one transition emitting two events, so+-- there is no separate Continue command in the sequence.+canonicalCmds :: [UserCmd]+canonicalCmds =+  [ StartRegistration (StartRegistrationData "alice@x" "Z9F4" (t 0)),+    ResendConfirmation (ResendConfirmationData "K2P7" (t 100)),+    ConfirmAccount (ConfirmAccountData "K2P7" (t 200)),+    FulfillGDPRRequest (FulfillGDPRRequestData (t 300))+  ]++-- | Hand-computed snapshot at the end of replay. Same values as+-- 'Keiki.Fixtures.UserRegistrationSpec.expectedSnapshot' so the two+-- specs validate the same end-state from opposite directions.+expectedSnapshot :: Snapshot+expectedSnapshot =+  ( "alice@x",+    "K2P7",+    t 100, -- registeredAt rotated by ResendConfirmation+    t 200, -- confirmedAt+    t 300 -- deletedAt+  )++-- | Run one decide/evolve round on the (s, regs) pair: the façade+-- emits zero or one event (on the state-refinement form), and+-- 'evolve' folds the (zero or one) event back into the state.+runRound ::+  Decider+    UserCmd+    UserEvent+    (Vertex, RegFile UserRegRegs)+    (InFlight Vertex UserEvent, RegFile UserRegRegs) ->+  (Vertex, RegFile UserRegRegs) ->+  UserCmd ->+  (Vertex, RegFile UserRegRegs)+runRound d acc cmd = foldl (evolve d) acc (decide d cmd acc)++spec :: Spec+spec = do+  describe "toDecider userReg" $ do+    it "round-trips the canonical command sequence to (Deleted, expectedSnapshot)" $ do+      let d = toDecider userReg+          (sFinal, regsFinal) = foldl (runRound d) (initialState d) canonicalCmds+      (sFinal, snapshot regsFinal) `shouldBe` (Deleted, expectedSnapshot)++    it "isTerminal d reports True after the canonical sequence" $ do+      let d = toDecider userReg+          end = foldl (runRound d) (initialState d) canonicalCmds+      isTerminal d end `shouldBe` True++    it "decide on the very first command emits the multi-event chain [RegistrationStarted, ConfirmationEmailSent]" $ do+      -- EP-19 M7: the entrance is now a length-2 multi-event edge,+      -- so decide returns both events from StartRegistration in+      -- declaration order.+      let d = toDecider userReg+          evs = decide d (head canonicalCmds) (initialState d)+      length evs `shouldBe` 2+      case evs of+        [RegistrationStarted _, ConfirmationEmailSent _] -> pure ()+        _ -> expectationFailure ("unexpected event sequence: " <> show evs)++    it "ε-edge limitation: GDPR from RequiresConfirmation yields [] from decide" $ do+      -- Drive the aggregate to RequiresConfirmation by chunk-replaying+      -- StartRegistration's two-event chain, then attempt the silent+      -- ε-edge (FulfillGDPRRequest before the user has confirmed).+      let d = toDecider userReg+          startCmd = StartRegistration (StartRegistrationData "bob@x" "S0E1" (t 0))+          startEvs = decide d startCmd (initialState d)+          preGdpr = case applyEvents userReg (initialState d) startEvs of+            Just sR -> sR+            Nothing -> error "applyEvents on the 2-event chain failed"+          gdprCmd = FulfillGDPRRequest (FulfillGDPRRequestData (t 999))+          evs = decide d gdprCmd preGdpr+          afterGdpr = foldl (evolve d) preGdpr evs+      length startEvs `shouldBe` 2+      fst preGdpr `shouldBe` RequiresConfirmation+      evs `shouldBe` []+      -- The ε-edge limitation: with no event, evolve is a no-op, so+      -- the façade leaves the state at RequiresConfirmation even+      -- though the keiki delta would transition to Deleted.+      fst afterGdpr `shouldBe` RequiresConfirmation++    it "ε-edge cross-check: delta does transition the same input to Deleted" $ do+      -- Companion to the previous case: confirm that the keiki+      -- transducer itself can drive the ε-edge via 'delta'. The point+      -- is that the limitation lives at the façade boundary, not in+      -- the underlying transducer.+      let d = toDecider userReg+          startCmd = StartRegistration (StartRegistrationData "carol@x" "T1V2" (t 0))+          startEvs = decide d startCmd (initialState d)+          preGdpr = case applyEvents userReg (initialState d) startEvs of+            Just sR -> sR+            Nothing -> error "applyEvents on the 2-event chain failed"+          (vAtRC, regsAtRC) = preGdpr+          gdprCmd = FulfillGDPRRequest (FulfillGDPRRequestData (t 999))+      vAtRC `shouldBe` RequiresConfirmation+      case delta userReg vAtRC regsAtRC gdprCmd of+        Just (vNext, _) -> vNext `shouldBe` Deleted+        Nothing -> expectationFailure "delta returned Nothing"++  describe "evolveStreaming (EP-19 M5)" $ do+    it "Settled PotentialCustomer ⊢ RegistrationStarted → InFlight RequiresConfirmation [ConfirmationEmailSent]" $ do+      -- After EP-19 M7 collapsed the entrance into a length-2+      -- multi-event edge, streaming replay through its head event+      -- transitions to the mid-chain wrapper carrying the expected+      -- tail event. The second event then unwraps to Settled.+      let d = toDecider userReg+          (_, regs0) = initialState d+          ev =+            RegistrationStarted+              (RegistrationStartedData "dave@x" "U2V3" (t 0))+      case evolveStreaming d (Settled PotentialCustomer, regs0) ev of+        Just (InFlight RequiresConfirmation [ConfirmationEmailSent _], _) -> pure ()+        Just (other, _) ->+          expectationFailure ("expected InFlight RequiresConfirmation [...], got " <> show other)+        Nothing -> expectationFailure "evolveStreaming returned Nothing"++    it "Settled Confirmed ⊢ AccountDeleted → Settled Deleted" $ do+      let d = toDecider userReg+          (_, regs0) = initialState d+          ev = AccountDeleted (AccountDeletedData "x@y" (t 200))+      case evolveStreaming d (Settled Confirmed, regs0) ev of+        Just (Settled Deleted, _) -> pure ()+        other -> expectationFailure ("unexpected: " <> show (fmap fst other))
+ test/Keiki/Fixtures/EmailDelivery.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TemplateHaskell #-}++-- | A small Email Delivery aggregate, the second worked example in+-- the keiki repository. Pairs with 'Jitsurei.UserRegistration'+-- as the canonical multi-aggregate fixture for+-- 'Keiki.Composition.compose' and the M4 acceptance tests of EP-11+-- (under MasterPlan 4).+--+-- The aggregate is two-vertex: an idle Pending state transitions to+-- a terminal Sent state on a 'SendEmail' command, emitting an+-- 'EmailSent' event. The shape is deliberately minimal — one+-- vertex transition, one command constructor, one event+-- constructor — so the composite tests focus on @compose@'s+-- mechanics rather than per-aggregate complexity.+module Keiki.Fixtures.EmailDelivery+  ( -- * Domain types+    Email,+    Subject,++    -- * Command payloads+    SendEmailData (..),+    EmailCmd (..),++    -- * Event payloads+    EmailSentData (..),+    EmailEvent (..),++    -- * Register file and control vertices+    EmailRegs,+    EmailVertex (..),++    -- * The transducer+    emailDelivery,+    emailDeliveryAST,+    emptyEmailRegs,++    -- * Wire constructors (exported for testing / composition)+    wireEmailSent,++    -- * Input constructors (exported for testing / composition)+    inCtorSendEmail,+    inpSendEmail,++    -- * B-presentation views (TH-derived; see EP-13 / MP-5)+    SEmailVertex (..),+    EmailView (..),+    emailView,+  )+where++import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics (Generic)+import Keiki.Builder ((.=))+import Keiki.Builder qualified as B+import Keiki.Core+import Keiki.Generics (emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveView, deriveWireCtors)+import Keiki.Symbolic (KnownInCtors (..), SomeInCtor (..))++-- * Domain types ------------------------------------------------------------++type Email = Text++type Subject = Text++-- * Command payloads --------------------------------------------------------++data SendEmailData = SendEmailData+  { recipient :: Email,+    subject :: Subject,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++data EmailCmd = SendEmail SendEmailData+  deriving (Eq, Show, Generic)++-- * Event payloads ----------------------------------------------------------++data EmailSentData = EmailSentData+  { recipient :: Email,+    subject :: Subject,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++data EmailEvent = EmailSent EmailSentData+  deriving (Eq, Show, Generic)++-- * Register file and control vertices -------------------------------------++type EmailRegs =+  '[ '("emailRecipient", Email),+     '("emailSubject", Subject),+     '("emailSentAt", UTCTime)+   ]++data EmailVertex = EmailPending | EmailSentVertex+  deriving (Eq, Show, Enum, Bounded)++-- | Initial register file. Each slot is pre-bound to a deferred+-- @"uninit: <slot>"@ error by 'Keiki.Generics.emptyRegFile'.+emptyEmailRegs :: RegFile EmailRegs+emptyEmailRegs = emptyRegFile++-- * Per-constructor input projections + guards (TH-derived) --------------++$( deriveAggregateCtors+     ''EmailCmd+     ''EmailRegs+     [ ("SendEmail", "SendEmail")+     ]+ )++-- | Enumerate the single 'InCtor' value of 'EmailCmd' so the+-- symbolic witness extractor can rebuild a concrete 'EmailCmd' from+-- an SBV model.+instance KnownInCtors EmailCmd where+  allInCtors = [SomeInCtor inCtorSendEmail]++-- * Wire constructors for events (TH-derived) ----------------------------++$( deriveWireCtors+     ''EmailEvent+     [ ("EmailSent", "EmailSent")+     ]+ )++-- * B-presentation views (TH-derived) ------------------------------------++--+-- The B-view exposes only the slots that are live in each control+-- vertex. 'EmailPending' is the initial state — no slots are bound,+-- so 'EmailPendingV' is nullary. 'EmailSentVertex' is terminal after+-- a 'SendEmail' command, by which point all three slots+-- ('emailRecipient', 'emailSubject', 'emailSentAt') are live, so+-- 'EmailSentVertexV' carries them as record fields.++$( deriveView+     ''EmailVertex+     ''EmailRegs+     "SEmailVertex"+     "EmailView"+     "emailView"+     [ ("EmailPending", []),+       ("EmailSentVertex", ["emailRecipient", "emailSubject", "emailSentAt"])+     ]+ )++-- * The transducer ---------------------------------------------------------++-- | The aggregate's transducer, authored with 'Keiki.Builder'. This+-- is the canonical form every downstream consumer+-- ('Keiki.Composition.compose', the deciders, the symbolic+-- analyses, the example specs) uses by name.+emailDelivery ::+  SymTransducer+    (HsPred EmailRegs EmailCmd)+    EmailRegs+    EmailVertex+    EmailCmd+    EmailEvent+emailDelivery = B.buildTransducer+  EmailPending+  emptyEmailRegs+  (\case EmailSentVertex -> True; _ -> False)+  do+    B.from EmailPending do+      B.onCmd inCtorSendEmail $ \d -> B.do+        B.slot @"emailRecipient" .= d.recipient+        B.slot @"emailSubject" .= d.subject+        B.slot @"emailSentAt" .= d.at+        B.emit+          wireEmailSent+          EmailSentTermFields+            { recipient = d.recipient,+              subject = d.subject,+              at = d.at+            }+        B.goto EmailSentVertex++-- * AST form (legacy, retained for the M4 equivalence test) ----------------++-- | The same transducer hand-authored against the post-MP-6+-- "Keiki.Core" AST. Retained as a side-by-side reference for the+-- 'Keiki.Fixtures.EmailDeliveryBuilderSpec' equivalence test;+-- removable in a follow-up plan once the migration is judged+-- stable.+emailDeliveryAST ::+  SymTransducer+    (HsPred EmailRegs EmailCmd)+    EmailRegs+    EmailVertex+    EmailCmd+    EmailEvent+emailDeliveryAST =+  SymTransducer+    { edgesOut = emailDeliveryASTEdges,+      initial = EmailPending,+      initialRegs = emptyEmailRegs,+      isFinal = \case EmailSentVertex -> True; _ -> False+    }++emailDeliveryASTEdges ::+  EmailVertex ->+  [Edge (HsPred EmailRegs EmailCmd) EmailRegs EmailCmd EmailEvent EmailVertex]+emailDeliveryASTEdges = \case+  EmailPending ->+    [ Edge+        { guard = isSendEmail,+          update =+            USet+              (#emailRecipient :: IndexN "emailRecipient" EmailRegs Email)+              (inpSendEmail #recipient)+              `combine` USet+                (#emailSubject :: IndexN "emailSubject" EmailRegs Subject)+                (inpSendEmail #subject)+              `combine` USet+                (#emailSentAt :: IndexN "emailSentAt" EmailRegs UTCTime)+                (inpSendEmail #at),+          output =+            [ pack+                inCtorSendEmail+                wireEmailSent+                ( OFCons+                    (inpSendEmail #recipient)+                    ( OFCons+                        (inpSendEmail #subject)+                        (OFCons (inpSendEmail #at) OFNil)+                    )+                )+            ],+          target = EmailSentVertex+        }+    ]+  EmailSentVertex -> []
+ test/Keiki/Fixtures/UserRegistration.hs view
@@ -0,0 +1,512 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TemplateHaskell #-}++-- | The User Registration aggregate from synthesis §4, transcribed in+-- the v1 'Keiki.Core' DSL. This module is the smoke test for the+-- master plan's "the synthesis holds" gate.+--+-- See:+--+--   * @docs/research/synthesis-c-foundation-b-presentation-with-worked-examples.md@+--     §4 — the original walkthrough.+--   * @docs/research/dsl-shape-for-symbolic-register.md@ — the DSL note's+--     "Worked example" section, which this module reproduces.+--+-- v1 deviations from synthesis §4:+--+--   * 'AccountConfirmedData' carries the @confirmCode@ field (synthesis+--     §4 fix-1). This is the "fixed" schema. The "unfixed" schema —+--     'Jitsurei.UserRegistrationV0' — is a separate module that+--     drops the field for the M7 hidden-input demonstration.+--   * 'ResendConfirmationData' carries a @code@ field (the new+--     confirmation code). Per the EP-3 effects-boundary note, fresh+--     codes are generated by the runtime adapter, not pulled from+--     'IO' inside the transducer.+--   * Each output is built with 'OPack' plus a v1 hand-written+--     inverse. The DSL note's 'OPack' was extended in M4 to carry that+--     inverse; see EP-4's Decision Log.+module Keiki.Fixtures.UserRegistration+  ( -- * Domain types+    Email,+    ConfirmationCode,++    -- * Command payloads+    StartRegistrationData (..),+    ConfirmAccountData (..),+    ResendConfirmationData (..),+    FulfillGDPRRequestData (..),+    UserCmd (..),++    -- * Event payloads+    RegistrationStartedData (..),+    ConfirmationEmailSentData (..),+    AccountConfirmedData (..),+    ConfirmationResentData (..),+    AccountDeletedData (..),+    UserEvent (..),++    -- * Register file and control vertices+    UserRegRegs,+    Vertex (..),++    -- * The transducer+    userReg,+    userRegAST,+    emptyRegs,++    -- * Multi-event driver configuration (EP-20 M4)++    -- * Wire constructors (exported for testing)+    wireRegistrationStarted,+    wireConfirmationEmailSent,+    wireAccountConfirmed,+    wireConfirmationResent,+    wireAccountDeleted,++    -- * Input constructors (exported for testing and reuse)+    inCtorStart,+    inCtorConfirm,+    inCtorResend,+    inCtorGdpr,+    inpStart,+    inpConfirm,+    inpResend,+    inpGdpr,++    -- * B-presentation views (TH-derived; see EP-13 / MP-5)+    SUserVertex (..),+    UserView (..),+    userView,+  )+where++import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics (Generic)+import Keiki.Builder ((.=))+import Keiki.Builder qualified as B+import Keiki.Core+import Keiki.Generics (emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveView, deriveWireCtors)+import Keiki.Symbolic (KnownInCtors (..), SomeInCtor (..))++-- * Domain types ------------------------------------------------------------++type Email = Text++type ConfirmationCode = Text++-- * Command payloads --------------------------------------------------------++data StartRegistrationData = StartRegistrationData+  { email :: Email,+    confirmCode :: ConfirmationCode,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++data ConfirmAccountData = ConfirmAccountData+  { confirmCode :: ConfirmationCode,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++-- | Per the effects-boundary note: fresh confirmation codes are+-- generated by the runtime adapter and arrive in the command. The+-- pure layer never pulls randomness.+data ResendConfirmationData = ResendConfirmationData+  { code :: ConfirmationCode,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++newtype FulfillGDPRRequestData = FulfillGDPRRequestData {at :: UTCTime}+  deriving (Eq, Show, Generic)++data UserCmd+  = StartRegistration StartRegistrationData+  | ConfirmAccount ConfirmAccountData+  | ResendConfirmation ResendConfirmationData+  | FulfillGDPRRequest FulfillGDPRRequestData+  deriving (Eq, Show, Generic)++-- * Event payloads ----------------------------------------------------------++data RegistrationStartedData = RegistrationStartedData+  { email :: Email,+    confirmCode :: ConfirmationCode,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++newtype ConfirmationEmailSentData = ConfirmationEmailSentData {email :: Email}+  deriving (Eq, Show, Generic)++-- | Synthesis §4 fix-1 schema: includes the @confirmCode@ field.+data AccountConfirmedData = AccountConfirmedData+  { email :: Email,+    confirmCode :: ConfirmationCode,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++data ConfirmationResentData = ConfirmationResentData+  { email :: Email,+    confirmCode :: ConfirmationCode,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++data AccountDeletedData = AccountDeletedData+  { email :: Email,+    at :: UTCTime+  }+  deriving (Eq, Show, Generic)++data UserEvent+  = RegistrationStarted RegistrationStartedData+  | ConfirmationEmailSent ConfirmationEmailSentData+  | AccountConfirmed AccountConfirmedData+  | ConfirmationResent ConfirmationResentData+  | AccountDeleted AccountDeletedData+  deriving (Eq, Show, Generic)++-- * Register file and control vertices -------------------------------------++type UserRegRegs =+  '[ '("email", Email),+     '("confirmCode", ConfirmationCode),+     '("registeredAt", UTCTime),+     '("confirmedAt", UTCTime),+     '("deletedAt", UTCTime)+   ]++data Vertex+  = PotentialCustomer+  | RequiresConfirmation+  | Confirmed+  | Deleted+  deriving (Eq, Show, Enum, Bounded)++-- | Initial register file. Each slot is pre-bound to a deferred+-- @"uninit: <slot>"@ error by 'Keiki.Generics.emptyRegFile' so reads+-- of an uninitialized slot crash with a targeted message instead of+-- a silent bottom.+emptyRegs :: RegFile UserRegRegs+emptyRegs = emptyRegFile++-- * Per-constructor input projections + guards (TH-derived) --------------++--+-- One 'InCtor' value per command constructor describes how to match+-- and re-build the constructor's payload as a typed 'RegFile'. The+-- per-constructor 'inpFoo' helpers turn an 'Index' (typically written+-- via 'OverloadedLabels' as @inpStart #email@) into a 'Term' that+-- structurally projects the named field of the named command+-- constructor. The matching @isFoo@ guards reduce to+-- @PInCtor@ atoms that the SBV-backed 'BoolAlg' instance recognizes+-- symbolically. 'solveOutput' walks the 'OutFields' bound by an+-- edge's @output@ and reconstructs the input @ci@ mechanically; no+-- per-edge inverse function is needed.+--+-- All declarations in this section are emitted by the splice below;+-- the slot-list types come from 'Keiki.Generics.RegFieldsOf' applied+-- to each command payload's 'Generic' representation. Singleton+-- 'Continue' uses 'mkInCtor0' under the hood (no @inp@ projection+-- because @'Index' \'[]@ is uninhabited).++$( deriveAggregateCtors+     ''UserCmd+     ''UserRegRegs+     [ ("StartRegistration", "Start"),+       ("ConfirmAccount", "Confirm"),+       ("ResendConfirmation", "Resend"),+       ("FulfillGDPRRequest", "Gdpr")+     ]+ )++-- | Enumerate the five 'InCtor' values of 'UserCmd' so 'symSatExt'+-- can rebuild a concrete 'UserCmd' from an SBV model: the model's+-- @"inputCtor"@ string is matched against these entries' 'icName',+-- and the matching entry's @icBuild@ is called over a 'RegFile'+-- assembled from the @"inp/<icName>/<slot>"@ model values.+instance KnownInCtors UserCmd where+  allInCtors =+    [ SomeInCtor inCtorStart,+      SomeInCtor inCtorConfirm,+      SomeInCtor inCtorResend,+      SomeInCtor inCtorGdpr+    ]++-- * Wire constructors for events (TH-derived) ----------------------------++--+-- One 'WireCtor' value per event constructor. The nested-pair field+-- tuple comes from each event record's 'Generic' instance via+-- 'Keiki.Generics.FieldsOf'.++$( deriveWireCtors+     ''UserEvent+     [ ("RegistrationStarted", "RegistrationStarted"),+       ("ConfirmationEmailSent", "ConfirmationEmailSent"),+       ("AccountConfirmed", "AccountConfirmed"),+       ("ConfirmationResent", "ConfirmationResent"),+       ("AccountDeleted", "AccountDeleted")+     ]+ )++-- * B-presentation views (TH-derived) ------------------------------------++--+-- The B-view is a per-vertex projection on top of the shared+-- 'RegFile UserRegRegs'. For each control vertex 'v' the splice+-- generates a 'UserView' constructor that exposes only the slots the+-- vertex actually uses (the "live" slots). Pattern-matching on+-- @userView SConfirmed regs@ yields a @ConfirmedV { cEmail = …,+-- cConfirmedAt = … }@ value whose record selectors are the live+-- slots only — the type system blocks the reader from asking+-- @SPotentialCustomer@ for @cConfirmedAt@.+--+-- The projection is opt-in and downstream of the transducer: nothing+-- in 'userReg' below references 'userView'. See+-- @docs/research/genview-th-splice-design.md@ and the synthesis+-- note's §3 for the design rationale.++$( deriveView+     ''Vertex+     ''UserRegRegs+     "SUserVertex"+     "UserView"+     "userView"+     [ ("PotentialCustomer", []),+       ("RequiresConfirmation", ["email", "confirmCode"]),+       ("Confirmed", ["email", "confirmedAt"]),+       ("Deleted", ["email", "deletedAt"])+     ]+ )++-- * The transducer ---------------------------------------------------------++-- | The aggregate's transducer, authored with 'Keiki.Builder'. This+-- is the canonical form every downstream consumer+-- ('Keiki.Composition.compose', the deciders, the symbolic+-- analyses, the example specs) uses by name.+userReg ::+  SymTransducer+    (HsPred UserRegRegs UserCmd)+    UserRegRegs+    Vertex+    UserCmd+    UserEvent+userReg = B.buildTransducer+  PotentialCustomer+  emptyRegs+  (\case Deleted -> True; _ -> False)+  do+    B.from PotentialCustomer do+      -- EP-19 M7: collapsed entrance — two emits in one transition.+      B.onCmd inCtorStart $ \d -> B.do+        B.slot @"email" .= d.email+        B.slot @"confirmCode" .= d.confirmCode+        B.slot @"registeredAt" .= d.at+        B.emit+          wireRegistrationStarted+          RegistrationStartedTermFields+            { email = d.email,+              confirmCode = d.confirmCode,+              at = d.at+            }+        B.emit+          wireConfirmationEmailSent+          ConfirmationEmailSentTermFields {email = d.email}+        B.goto RequiresConfirmation++    B.from RequiresConfirmation do+      -- Right code: confirm. The InCtor-match guard from `onCmd`+      -- short-circuits the d.confirmCode read for non-ConfirmAccount+      -- inputs.+      B.onCmd inCtorConfirm $ \d -> B.do+        B.requireEq d.confirmCode #confirmCode+        B.slot @"confirmedAt" .= d.at+        B.emit+          wireAccountConfirmed+          AccountConfirmedTermFields+            { email = #email,+              confirmCode = d.confirmCode,+              at = d.at+            }+        B.goto Confirmed++      -- Resend: rotate the code (code arrives in the command).+      B.onCmd inCtorResend $ \d -> B.do+        B.slot @"confirmCode" .= d.code+        B.slot @"registeredAt" .= d.at+        B.emit+          wireConfirmationResent+          ConfirmationResentTermFields+            { email = #email,+              confirmCode = d.code,+              at = d.at+            }+        B.goto RequiresConfirmation++      -- GDPR before confirmation: silent ε-edge (no event).+      B.onCmd inCtorGdpr $ \d -> B.do+        B.slot @"deletedAt" .= d.at+        B.noEmit+        B.goto Deleted++    B.from Confirmed do+      B.onCmd inCtorGdpr $ \d -> B.do+        B.slot @"deletedAt" .= d.at+        B.emit+          wireAccountDeleted+          AccountDeletedTermFields+            { email = #email,+              at = d.at+            }+        B.goto Deleted++-- Deleted is terminal; defaults to [] without an explicit `from`.++-- * AST form (legacy, retained for the M5 equivalence test) ----------------++-- | The same transducer hand-authored against the post-MP-6+-- "Keiki.Core" AST. Retained as a side-by-side reference for the+-- 'Jitsurei.UserRegistrationBuilderSpec' equivalence test;+-- removable in a follow-up plan once the migration is judged+-- stable.+userRegAST ::+  SymTransducer+    (HsPred UserRegRegs UserCmd)+    UserRegRegs+    Vertex+    UserCmd+    UserEvent+userRegAST =+  SymTransducer+    { edgesOut = userRegASTEdges,+      initial = PotentialCustomer,+      initialRegs = emptyRegs,+      isFinal = \case Deleted -> True; _ -> False+    }++userRegASTEdges ::+  Vertex ->+  [Edge (HsPred UserRegRegs UserCmd) UserRegRegs UserCmd UserEvent Vertex]+userRegASTEdges = \case+  -- EP-19 M7: collapsed to one length-2 multi-event edge.+  PotentialCustomer ->+    [ Edge+        { guard = isStart,+          update =+            USet (#email :: IndexN "email" UserRegRegs Email) (inpStart #email)+              `combine` USet+                (#confirmCode :: IndexN "confirmCode" UserRegRegs ConfirmationCode)+                (inpStart #confirmCode)+              `combine` USet+                (#registeredAt :: IndexN "registeredAt" UserRegRegs UTCTime)+                (inpStart #at),+          output =+            [ pack+                inCtorStart+                wireRegistrationStarted+                ( OFCons+                    (inpStart #email)+                    ( OFCons+                        (inpStart #confirmCode)+                        (OFCons (inpStart #at) OFNil)+                    )+                ),+              pack+                inCtorStart+                wireConfirmationEmailSent+                (OFCons (inpStart #email) OFNil)+            ],+          target = RequiresConfirmation+        }+    ]+  RequiresConfirmation ->+    [ -- Right code: confirm. The 'isConfirm' conjunct short-circuits the+      -- inpConfirm read for non-ConfirmAccount inputs.+      Edge+        { guard =+            PAnd+              isConfirm+              ( inpConfirm #confirmCode+                  .== proj (#confirmCode :: Index UserRegRegs ConfirmationCode)+              ),+          update =+            USet+              (#confirmedAt :: IndexN "confirmedAt" UserRegRegs UTCTime)+              (inpConfirm #at),+          output =+            [ pack+                inCtorConfirm+                wireAccountConfirmed+                ( OFCons+                    (proj (#email :: Index UserRegRegs Email))+                    ( OFCons+                        (inpConfirm #confirmCode)+                        (OFCons (inpConfirm #at) OFNil)+                    )+                )+            ],+          target = Confirmed+        },+      -- Resend: rotate the code (code arrives in the command).+      Edge+        { guard = isResend,+          update =+            USet+              (#confirmCode :: IndexN "confirmCode" UserRegRegs ConfirmationCode)+              (inpResend #code)+              `combine` USet+                (#registeredAt :: IndexN "registeredAt" UserRegRegs UTCTime)+                (inpResend #at),+          output =+            [ pack+                inCtorResend+                wireConfirmationResent+                ( OFCons+                    (proj (#email :: Index UserRegRegs Email))+                    ( OFCons+                        (inpResend #code)+                        (OFCons (inpResend #at) OFNil)+                    )+                )+            ],+          target = RequiresConfirmation+        },+      -- GDPR before confirmation: silent ε-edge (no event).+      Edge+        { guard = isGdpr,+          update =+            USet+              (#deletedAt :: IndexN "deletedAt" UserRegRegs UTCTime)+              (inpGdpr #at),+          output = [],+          target = Deleted+        }+    ]+  Confirmed ->+    [ Edge+        { guard = isGdpr,+          update =+            USet+              (#deletedAt :: IndexN "deletedAt" UserRegRegs UTCTime)+              (inpGdpr #at),+          output =+            [ pack+                inCtorGdpr+                wireAccountDeleted+                ( OFCons+                    (proj (#email :: Index UserRegRegs Email))+                    (OFCons (inpGdpr #at) OFNil)+                )+            ],+          target = Deleted+        }+    ]+  Deleted -> []
+ test/Keiki/Generics/THSpec.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE TemplateHaskell #-}++module Keiki.Generics.THSpec (spec) where++import Data.Map.Strict qualified as Map+import Data.Maybe (isNothing)+import Data.Proxy (Proxy (..))+import Data.Set qualified as Set+import GHC.Generics (Generic)+import Keiki.Core+import Keiki.Generics ()+import Keiki.Generics.TH+import Test.Hspec++-- A toy aggregate used purely to exercise the TH splices in+-- isolation. Two commands: one record-payload, one singleton. The+-- spec asserts the splices produce identifiers with the expected+-- behaviour — name, match/build, and the @inp@ projection.++data ToyData = ToyData {x :: Int, y :: Int}+  deriving (Eq, Show, Generic)++data ToyCmd+  = DoIt ToyData+  | NoArgs+  deriving (Eq, Show, Generic)++type ToyRegs =+  '[ '("x", Int),+     '("y", Int)+   ]++$( deriveAggregateCtors+     ''ToyCmd+     ''ToyRegs+     [ ("DoIt", "DoIt"),+       ("NoArgs", "NoArgs")+     ]+ )++-- | Empty register file populated with sentinel values. The 'inp'+-- projection test below reads from the input symbol via+-- 'TInpCtorField', not from the register file, so the values here do+-- not matter — they only need to be present so the carrier+-- type-checks. The 'KnownSymbol' constraints on each 'Proxy' are+-- discharged by the slot-list types in scope.+toyRegs :: RegFile ToyRegs+toyRegs = RCons (Proxy @"x") 0 (RCons (Proxy @"y") 0 RNil)++-- A second toy aggregate with distinct constructor names, used to+-- exercise the zero-spec @*All@ splices: 'deriveAggregateCtorsAll'+-- enumerates every command constructor, 'deriveWireCtorsAll' every+-- event constructor, each defaulting its short-name suffix to the+-- constructor's own name. Distinct names keep the generated+-- identifiers from colliding with the 'ToyCmd' splice output above.++data WidgetData = WidgetData {wa :: Int, wb :: Int}+  deriving (Eq, Show, Generic)++data AutoCmd+  = MakeWidget WidgetData+  | Sweep+  deriving (Eq, Show, Generic)++type AutoRegs =+  '[ '("wa", Int),+     '("wb", Int)+   ]++data GadgetData = GadgetData {gz :: Int}+  deriving (Eq, Show, Generic)++data AutoEvent+  = WidgetMade GadgetData+  | Swept+  deriving (Eq, Show, Generic)++$(deriveAggregateCtorsAll ''AutoCmd ''AutoRegs)+$(deriveWireCtorsAll ''AutoEvent)++autoRegs :: RegFile AutoRegs+autoRegs = RCons (Proxy @"wa") 0 (RCons (Proxy @"wb") 0 RNil)++-- A third toy aggregate with fresh constructor names, derived through+-- the single fused 'deriveAggregate' splice. The assertions below+-- prove one splice produced both the command-side+-- (@inCtorFoo@ / @inpFoo@ / @isTick@) and event-side (@wireFizzed@ /+-- @FizzedTermFields@) declarations.++data FooData = FooData {fa :: Int}+  deriving (Eq, Show, Generic)++data FusedCmd+  = Foo FooData+  | Tick+  deriving (Eq, Show, Generic)++type FusedRegs =+  '[ '("fa", Int)]++data FizzData = FizzData {fb :: Int}+  deriving (Eq, Show, Generic)++data FusedEvent+  = Fizzed FizzData+  deriving (Eq, Show, Generic)++$(deriveAggregate ''FusedCmd ''FusedRegs ''FusedEvent)++fusedRegs :: RegFile FusedRegs+fusedRegs = RCons (Proxy @"fa") 0 RNil++-- A fourth toy aggregate exercising 'deriveAggregateCtorsWith': one+-- constructor is overridden to an abbreviated short name, one keeps its+-- own name by default, and one is excluded entirely. The assertions+-- prove the overridden helper carries the abbreviated identifier, the+-- default helper keeps its constructor name, and the excluded+-- constructor produced no helper (the latter is verified by the fact+-- that this module compiles only because it never references+-- @inCtorSkipped@).++data OverData = OverData {oa :: Int}+  deriving (Eq, Show, Generic)++data OverCmd+  = LongCommandName OverData -- overridden to short "Brief"+  | Plain OverData -- default short "Plain"+  | Skipped -- excluded entirely+  deriving (Eq, Show, Generic)++type OverRegs = '[ '("oa", Int)]++$( deriveAggregateCtorsWith+     ''OverCmd+     ''OverRegs+     defaultDeriveCtorOptions+       { suffixOverrides = Map.fromList [("LongCommandName", "Brief")],+         excludeCtors = Set.fromList ["Skipped"]+       }+ )++overRegs :: RegFile OverRegs+overRegs = RCons (Proxy @"oa") 0 RNil++-- A fifth toy aggregate exercising 'deriveWireCtorsWith' on the event+-- side: one constructor is overridden to an abbreviated short name, one+-- keeps its own name, and one is excluded. Mirrors the OverCmd fixture.++data EvtData = EvtData {ea :: Int}+  deriving (Eq, Show, Generic)++data OverEvent+  = SomethingHappenedAtLength EvtData -- override -> "Happened"+  | Routine EvtData -- default -> "Routine"+  | Ignored -- excluded+  deriving (Eq, Show, Generic)++$( deriveWireCtorsWith+     ''OverEvent+     defaultDeriveWireOptions+       { suffixOverridesW = Map.fromList [("SomethingHappenedAtLength", "Happened")],+         excludeCtorsW = Set.fromList ["Ignored"]+       }+ )++spec :: Spec+spec = do+  describe "deriveAggregateCtors on a record-payload constructor (DoIt)" $ do+    it "names the InCtor after the source ctor" $+      icName inCtorDoIt `shouldBe` "DoIt"++    it "matches a DoIt value and yields a populated RegFile" $+      let payload = ToyData 17 23+          regfile = case icMatch inCtorDoIt (DoIt payload) of+            Just rf -> rf+            Nothing -> error "icMatch returned Nothing on DoIt"+       in (regfile ! #x, regfile ! #y) `shouldBe` (17, 23)++    it "rejects a non-DoIt value" $+      isNothing (icMatch inCtorDoIt NoArgs) `shouldBe` True++    it "rebuilds DoIt from a populated RegFile" $+      let payload = ToyData 17 23+          rf = case icMatch inCtorDoIt (DoIt payload) of+            Just r -> r+            Nothing -> error "set-up icMatch failed"+       in icBuild inCtorDoIt rf `shouldBe` DoIt payload++    it "evalTerm (inpDoIt #x) on a DoIt input reads the x field" $+      evalTerm (inpDoIt #x) toyRegs (DoIt (ToyData 5 9)) `shouldBe` 5++    it "evalPred isDoIt agrees with constructor match" $ do+      evalPred isDoIt toyRegs (DoIt (ToyData 0 0)) `shouldBe` True+      evalPred isDoIt toyRegs NoArgs `shouldBe` False++  describe "deriveAggregateCtors on a singleton constructor (NoArgs)" $ do+    it "names the InCtor after the source ctor" $+      icName inCtorNoArgs `shouldBe` "NoArgs"++    it "matches the NoArgs singleton" $+      case icMatch inCtorNoArgs NoArgs of+        Just _ -> pure ()+        Nothing -> expectationFailure "icMatch returned Nothing on NoArgs"++    it "rejects a record-payload value" $+      isNothing (icMatch inCtorNoArgs (DoIt (ToyData 0 0))) `shouldBe` True++    it "evalPred isNoArgs agrees with constructor match" $ do+      evalPred isNoArgs toyRegs NoArgs `shouldBe` True+      evalPred isNoArgs toyRegs (DoIt (ToyData 0 0)) `shouldBe` False++  describe "deriveAggregateCtorsAll (no spec list)" $ do+    it "discovers the record-payload command and names it after the ctor" $+      icName inCtorMakeWidget `shouldBe` "MakeWidget"++    it "matches MakeWidget and yields a populated RegFile" $+      let regfile = case icMatch inCtorMakeWidget (MakeWidget (WidgetData 3 4)) of+            Just rf -> rf+            Nothing -> error "icMatch returned Nothing on MakeWidget"+       in (regfile ! #wa, regfile ! #wb) `shouldBe` (3, 4)++    it "evalTerm (inpMakeWidget #wa) reads the wa field" $+      evalTerm (inpMakeWidget #wa) autoRegs (MakeWidget (WidgetData 5 9)) `shouldBe` 5++    it "discovers the singleton command and its guard" $ do+      icName inCtorSweep `shouldBe` "Sweep"+      evalPred isSweep autoRegs Sweep `shouldBe` True+      evalPred isSweep autoRegs (MakeWidget (WidgetData 0 0)) `shouldBe` False++  describe "deriveWireCtorsAll (no spec list)" $ do+    it "discovers the record-payload event and rebuilds it" $ do+      wcName wireWidgetMade `shouldBe` "WidgetMade"+      wcBuild wireWidgetMade (7, ()) `shouldBe` WidgetMade (GadgetData 7)++    it "discovers the singleton event and rebuilds it" $ do+      wcName wireSwept `shouldBe` "Swept"+      wcBuild wireSwept () `shouldBe` Swept++  describe "deriveAggregate (fused command + event)" $ do+    it "generates the command-side InCtor" $ do+      icName inCtorFoo `shouldBe` "Foo"+      evalTerm (inpFoo #fa) fusedRegs (Foo (FooData 11)) `shouldBe` 11++    it "generates the command-side singleton guard" $ do+      evalPred isTick fusedRegs Tick `shouldBe` True+      evalPred isTick fusedRegs (Foo (FooData 0)) `shouldBe` False++    it "generates the event-side WireCtor" $ do+      wcName wireFizzed `shouldBe` "Fizzed"+      wcBuild wireFizzed (13, ()) `shouldBe` Fizzed (FizzData 13)++  describe "deriveAggregateCtorsWith (overrides + excludes)" $ do+    it "uses the override short name for the identifier" $+      icName inCtorBrief `shouldBe` "LongCommandName"++    it "matches and reads through the overridden helper" $+      evalTerm (inpBrief #oa) overRegs (LongCommandName (OverData 7))+        `shouldBe` 7++    it "defaults the non-overridden constructor to its own name" $+      icName inCtorPlain `shouldBe` "Plain"++    it "the override guard distinguishes the two record ctors" $ do+      evalPred isBrief overRegs (LongCommandName (OverData 0)) `shouldBe` True+      evalPred isBrief overRegs (Plain (OverData 0)) `shouldBe` False++  -- The excluded constructor 'Skipped' generates no helpers: there is+  -- no inCtorSkipped / isSkipped in scope. Referencing one would fail+  -- to compile, which is the intended behaviour.++  describe "deriveWireCtorsWith (overrides + excludes)" $ do+    it "uses the override short name for the event identifier" $+      wcName wireHappened `shouldBe` "SomethingHappenedAtLength"++    it "rebuilds the overridden event through the abbreviated helper" $+      wcBuild wireHappened (5, ()) `shouldBe` SomethingHappenedAtLength (EvtData 5)++    it "defaults the non-overridden event to its own name" $ do+      wcName wireRoutine `shouldBe` "Routine"+      wcBuild wireRoutine (9, ()) `shouldBe` Routine (EvtData 9)++-- The excluded event constructor 'Ignored' generates no helper: there+-- is no wireIgnored in scope. Referencing it would fail to compile.
+ test/Keiki/NoThunksSpec.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DerivingVia #-}+-- 'Vertex' is a user-defined nullary enum in+-- "Keiki.Fixtures.UserRegistration"; we add an orphan+-- @NoThunks Vertex@ here purely for the canonical-log assertion.+-- This mirrors the pattern a real embedder would use in their own+-- module: derive via 'OnlyCheckWhnf' for small enum-like vertices.+{-# OPTIONS_GHC -Wno-orphans #-}++module Keiki.NoThunksSpec (spec) where++import Control.DeepSeq (force)+import Data.Maybe (isNothing)+import Data.Proxy (Proxy (..))+import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import Keiki.Core (RegFile (..), reconstitute)+import Keiki.Fixtures.UserRegistration+  ( AccountConfirmedData (..),+    AccountDeletedData (..),+    ConfirmationEmailSentData (..),+    ConfirmationResentData (..),+    RegistrationStartedData (..),+    UserEvent (..),+    Vertex,+    userReg,+  )+import Keiki.NoThunks ()+import NoThunks.Class (NoThunks, OnlyCheckWhnf (..), noThunks)+import Test.Hspec++deriving via OnlyCheckWhnf Vertex instance NoThunks Vertex++-- | A trivial UTC-time fixture, mirroring the one in+-- 'Keiki.Fixtures.UserRegistrationSpec', except deep-forced.+--+-- 'Data.Time.Clock.UTCTime'\'s fields are *lazy* — bang-binding the+-- whole value reaches WHNF (the outer constructor) but leaves+-- @utctDay@ and @utctDayTime@ as thunks. The bundled @nothunks@+-- instance derives via 'NoThunks.Class.InspectHeap' and walks the+-- entire heap closure, so it would report those internal thunks as+-- (false-positive) leaks. 'Control.DeepSeq.force' uses the @time@+-- package's 'Control.DeepSeq.NFData' instance to evaluate the+-- whole structure to NF, dispelling the false positive.+t :: Integer -> UTCTime+t s = force (UTCTime (fromGregorian 2026 5 1) (secondsToDiffTime s))++-- | The synthesis §4 canonical event log. Reproduced inline (rather+-- than imported) because the upstream definition lives in another+-- spec module's local scope; coupling test modules to share a+-- five-line literal would cost more than it saves.+canonicalLog :: [UserEvent]+canonicalLog =+  let !t0 = t 0+      !t100 = t 100+      !t200 = t 200+      !t300 = t 300+   in [ RegistrationStarted (RegistrationStartedData "alice@x" "Z9F4" t0),+        ConfirmationEmailSent (ConfirmationEmailSentData "alice@x"),+        ConfirmationResent (ConfirmationResentData "alice@x" "K2P7" t100),+        AccountConfirmed (AccountConfirmedData "alice@x" "K2P7" t200),+        AccountDeleted (AccountDeletedData "alice@x" t300)+      ]++-- A genuine thunk for the sanity check. Using @(1 + 1) :: Int@ as a+-- fixture is unreliable: GHC at -O1 may constant-fold it before the+-- thunk is ever stored. NOINLINE on a top-level binding keeps the+-- reference opaque to the optimizer.+{-# NOINLINE leakySlotValue #-}+leakySlotValue :: Int+leakySlotValue =+  error+    "leakySlotValue should not be forced; the spec only inspects \+    \the RegFile spine for thunk presence"++spec :: Spec+spec = describe "NoThunks instances" $ do+  it "RNil contains no thunks" $ do+    result <- noThunks [] RNil+    isNothing result `shouldBe` True++  it "reconstitute on the canonical UserRegistration log returns thunk-free state" $ do+    -- Bang-bind the (state, regs) tuple to mirror the realistic+    -- embedder pattern: after each 'step' the application forces the+    -- result before observing it. Without this, 'noThunks' would+    -- correctly report the *outer* tuple-projection thunk and never+    -- reach the RegFile spine — that is a binding artefact, not a+    -- leak in the state itself.+    case reconstitute userReg canonicalLog of+      Nothing -> expectationFailure "reconstitute returned Nothing"+      Just (!s, !regs) -> do+        sResult <- noThunks ["vertex"] s+        regsResult <- noThunks ["regfile"] regs+        case regsResult of+          Nothing -> pure ()+          Just ti -> expectationFailure $ "regfile thunk: " <> show ti+        case sResult of+          Nothing -> pure ()+          Just ti -> expectationFailure $ "vertex thunk: " <> show ti++  it "a deliberately-lazy RegFile reports a thunk (sanity check)" $ do+    let leaky :: RegFile '[ '("x", Int)]+        leaky = RCons (Proxy @"x") leakySlotValue RNil+    result <- noThunks ["leaky"] leaky+    case result of+      Just _ -> pure ()+      Nothing ->+        expectationFailure+          "expected NoThunks to detect the unevaluated leakySlotValue thunk"
+ test/Keiki/OperatorsQualifiedSpec.hs view
@@ -0,0 +1,39 @@+module Keiki.OperatorsQualifiedSpec (spec) where++import Keiki.Core (HsPred, RegFile (..), evalPred, lit)+import Keiki.Operators qualified as K+import Test.Hspec++-- Simulate the lens clash: a local, unqualified (.>) that is NOT keiki's+-- greater-than. If the qualified K..> below accidentally resolved to this+-- one, the predicate would be ill-typed (Int, not HsPred) and would not+-- compile; if a plain (.>) were used it would shadow keiki's. The point is+-- that K..> reaches keiki's operator while (.>) stays free for other uses.+(.>) :: Int -> Int -> Int+a .> b = a + b++infixl 6 .>++-- A trivial command type; the operators here never read it.+data NoCmd = NoCmd deriving (Eq, Show)++-- Evaluate a predicate over the empty register file / NoCmd input.+runP :: HsPred '[] NoCmd -> Bool+runP pr = evalPred pr RNil NoCmd++-- A guard built entirely through the qualified import.+sampleGuard :: HsPred '[] NoCmd+sampleGuard = (lit (5 :: Int) K..> lit 3) K..&& (lit (2 :: Int) K..>= lit 2)++spec :: Spec+spec = do+  describe "qualified Keiki.Operators resolves the (.>) clash" $ do+    it "K..> builds keiki's greater-than predicate" $ do+      runP (lit (5 :: Int) K..> lit 3) `shouldBe` True+      runP (lit (3 :: Int) K..> lit 3) `shouldBe` False+    it "the local unqualified (.>) is still usable and is NOT keiki's" $+      (2 .> 3) `shouldBe` 5 -- our local addition, untouched+    it "a compound guard via qualified ops evaluates correctly" $+      runP sampleGuard `shouldBe` True+    it "arithmetic via qualified ops feeds a comparison" $+      runP (lit (10 :: Int) K..<= lit 3 K..* lit 4) `shouldBe` True
+ test/Keiki/OperatorsSpec.hs view
@@ -0,0 +1,80 @@+module Keiki.OperatorsSpec (spec) where++import Keiki.Core+import Test.Hspec++-- A trivial command type; the operators here never read it.+data NoCmd = NoCmd deriving (Eq, Show)++-- Evaluate a predicate over the empty register file / NoCmd input.+p :: HsPred '[] NoCmd -> Bool+p pr = evalPred pr RNil NoCmd++-- Evaluate an Int term the same way.+n :: Term '[] NoCmd ifs Int -> Int+n t = evalTerm t RNil NoCmd++-- A guard written at the aliased type Pred…+sampleGuard :: Pred '[] NoCmd+sampleGuard = lit (1 :: Int) .>= lit 0 .&& lit (2 :: Int) ./= lit 5++-- …is accepted where an HsPred is expected (evalPred takes HsPred).+-- If `Pred` were not a true synonym for `HsPred`, this would not compile.++spec :: Spec+spec = do+  describe "comparison operators" $ do+    it ".>= computes >=" $ do+      p (lit (5 :: Int) .>= lit 3) `shouldBe` True+      p (lit (3 :: Int) .>= lit 3) `shouldBe` True+      p (lit (2 :: Int) .>= lit 3) `shouldBe` False+    it ".<= computes <=" $ do+      p (lit (2 :: Int) .<= lit 3) `shouldBe` True+      p (lit (4 :: Int) .<= lit 3) `shouldBe` False+    it ".> computes >" $ do+      p (lit (4 :: Int) .> lit 3) `shouldBe` True+      p (lit (3 :: Int) .> lit 3) `shouldBe` False+    it ".< computes <" $ do+      p (lit (2 :: Int) .< lit 3) `shouldBe` True+      p (lit (3 :: Int) .< lit 3) `shouldBe` False+    it "./= computes /=" $ do+      p (lit (2 :: Int) ./= lit 3) `shouldBe` True+      p (lit (3 :: Int) ./= lit 3) `shouldBe` False++  describe "operator equals its constructor (behavioural identity)" $ do+    it ".>= matches PCmp CmpGe on a grid" $+      [p (lit a .>= lit b) | a <- g, b <- g]+        `shouldBe` [p (PCmp CmpGe (lit a) (lit b)) | a <- g, b <- g]+    it ".== matches PEq on a grid" $+      [p (lit a .== lit b) | a <- g, b <- g]+        `shouldBe` [p (PEq (lit a) (lit b)) | a <- g, b <- g]+    it "./= matches PNot . PEq on a grid" $+      [p (lit a ./= lit b) | a <- g, b <- g]+        `shouldBe` [p (PNot (PEq (lit a) (lit b))) | a <- g, b <- g]++  describe "logical operators" $ do+    it ".&& is conjunction" $ do+      p (lit (1 :: Int) .== lit 1 .&& lit (2 :: Int) .== lit 2) `shouldBe` True+      p (lit (1 :: Int) .== lit 1 .&& lit (2 :: Int) .== lit 3) `shouldBe` False+    it ".|| is disjunction" $ do+      p (lit (1 :: Int) .== lit 9 .|| lit (2 :: Int) .== lit 2) `shouldBe` True+      p (lit (1 :: Int) .== lit 9 .|| lit (2 :: Int) .== lit 8) `shouldBe` False+    it "pnot is negation" $ do+      p (pnot (lit (1 :: Int) .== lit 1)) `shouldBe` False+      p (pnot (lit (1 :: Int) .== lit 2)) `shouldBe` True++  describe "arithmetic operators (and fixity)" $ do+    it ".+ .- .* compute the arithmetic" $ do+      n (lit 2 .+ lit 3) `shouldBe` 5+      n (lit 7 .- lit 4) `shouldBe` 3+      n (lit 6 .* lit 7) `shouldBe` 42+    it ".* binds tighter than .+ (infixl 7 vs 6)" $+      n (lit 2 .+ lit 3 .* lit 4) `shouldBe` 14+    it "arithmetic feeds a comparison without parens" $+      p (lit (10 :: Int) .<= lit 3 .* lit 4) `shouldBe` True++  describe "type synonyms" $+    it "Pred is interchangeable with HsPred" $+      evalPred sampleGuard RNil NoCmd `shouldBe` True+  where+    g = [1, 2, 3] :: [Int]
+ test/Keiki/ProfunctorSpec.hs view
@@ -0,0 +1,230 @@+-- | Acceptance tests for 'Keiki.Profunctor' (EP-27 of MasterPlan 9).+--+-- The fixture is the existing 'Keiki.Fixtures.EmailDelivery'+-- aggregate. Each combinator is applied and forward processing /+-- inversion / single-valuedness / hidden-input behaviour is asserted+-- against the documented contract.+module Keiki.ProfunctorSpec (spec) where++import Control.Exception (ErrorCall (..), evaluate)+import Data.Profunctor (Profunctor (..), dimap)+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+import GHC.Generics (Generic)+import Keiki.Core+import Keiki.Fixtures.EmailDelivery+import Keiki.Profunctor+import Keiki.Symbolic (isSingleValuedSym, withSymPred)+import Test.Hspec++-- | A wrapper command type used to exercise 'lmapCi'.+newtype WrappedCmd = WrappedCmd {unwrapCmd :: EmailCmd}+  deriving stock (Eq, Show, Generic)++-- | A wrapper event type used to exercise 'rmapCo'.+newtype WrappedEvent = WrappedEvent {unwrapEvent :: EmailEvent}+  deriving stock (Eq, Show, Generic)++-- | A sum command type used to exercise 'lmapMaybeCi' as a router.+data RouterCmd+  = ToEmail EmailCmd+  | OtherCmd+  deriving stock (Eq, Show, Generic)++-- | Routing function: project the EmailCmd arm of 'RouterCmd'.+router :: RouterCmd -> Maybe EmailCmd+router (ToEmail c) = Just c+router OtherCmd = Nothing++-- | A representative input we will fire through transducers.+sampleEmailCmd :: EmailCmd+sampleEmailCmd =+  SendEmail+    SendEmailData+      { recipient = "alice@example.com",+        subject = "hello",+        at = sampleAt+      }++sampleAt :: UTCTime+sampleAt = UTCTime (fromGregorian 2026 5 3) (secondsToDiffTime 0)++-- | Fire a single command through a transducer's initial state and+-- collect '(target, output)' pairs from every active (guard-true)+-- edge. This is sufficient to assert the rewriters preserve forward+-- behaviour without going through 'delta'/'omega''s+-- single-valuedness gate.+fireFromInitial ::+  SymTransducer (HsPred rs ci) rs s ci co ->+  ci ->+  [(s, [co])]+fireFromInitial t ci =+  [ (target e, map (\o -> evalOut o (initialRegs t) ci) (output e))+  | e <- edgesOut t (initial t),+    evalPred (guard e) (initialRegs t) ci+  ]++-- | Pull a single edge's structural OPack output list for+-- assertions about the rewriter's effect on the AST itself.+firstEdgeOutput ::+  SymTransducer (HsPred rs ci) rs s ci co ->+  [OutTerm rs ci co]+firstEdgeOutput t = case edgesOut t (initial t) of+  [] -> []+  (e : _) -> output e++-- | 'fireFromInitial' but drops the (existential) vertex type so the+-- result can escape an existential pattern. Returns the per-edge+-- output (or Nothing for ε-edges) in the same order edges were+-- fired.+fireOutputsOnly ::+  SymTransducer (HsPred rs ci) rs s ci co ->+  ci ->+  [[co]]+fireOutputsOnly t ci = map snd (fireFromInitial t ci)++spec :: Spec+spec = do+  describe "lmapCi" $ do+    it "preserves forward processing through the rewritten transducer" $ do+      let lmapped = lmapCi unwrapCmd emailDelivery+          original = emailDelivery+          fromOriginal = fireFromInitial original sampleEmailCmd+          fromLmapped = fireFromInitial lmapped (WrappedCmd sampleEmailCmd)+      length fromOriginal `shouldBe` length fromLmapped+      map fst fromOriginal `shouldBe` map fst fromLmapped+      map snd fromOriginal `shouldBe` map snd fromLmapped++    it "raises a poisoned-icBuild error when solveOutput is forced on lmapped edges" $ do+      let lmapped = lmapCi unwrapCmd emailDelivery+      case firstEdgeOutput lmapped of+        [] -> expectationFailure "lmapped EmailDelivery should have a non-eps edge output"+        (o : _) -> do+          -- The structural inverse returns 'Just (icBuild …)' — the+          -- 'Just' is in WHNF but the inner thunk only fires when+          -- forced. lmapCi's contract: if you try to recover a 'ci'+          -- from a wire event, the poisoned icBuild raises a clear+          -- error. We force the inner value and assert the throw.+          let event =+                EmailSent+                  EmailSentData+                    { recipient = "alice@example.com",+                      subject = "hello",+                      at = sampleAt+                    }+              recovered :: Maybe WrappedCmd+              recovered = solveOutput o (initialRegs lmapped) event+          case recovered of+            Nothing ->+              expectationFailure+                "lmapped solveOutput unexpectedly returned Nothing — \+                \the contract is 'Just (poison)' not 'Nothing'"+            Just c ->+              evaluate c+                `shouldThrow` errorCall' "icBuild on a contramapped InCtor"++    it "preserves isSingleValuedSym" $ do+      isSingleValuedSym (withSymPred (lmapCi unwrapCmd emailDelivery))+        `shouldBe` True++  describe "rmapCo" $ do+    it "post-composes the output through the supplied function" $ do+      let rmapped = rmapCo WrappedEvent emailDelivery+          fromRmapped = fireFromInitial rmapped sampleEmailCmd+          expected =+            [ ( EmailSentVertex,+                [ WrappedEvent+                    ( EmailSent+                        EmailSentData+                          { recipient = "alice@example.com",+                            subject = "hello",+                            at = sampleAt+                          }+                    )+                ]+              )+            ]+      fromRmapped `shouldBe` expected++    it "returns Nothing from solveOutput on rmapped edges" $ do+      let rmapped = rmapCo WrappedEvent emailDelivery+      case firstEdgeOutput rmapped of+        [] -> expectationFailure "rmapped EmailDelivery should have a non-eps edge output"+        (o : _) -> do+          let wrappedEvent =+                WrappedEvent+                  ( EmailSent+                      EmailSentData+                        { recipient = "alice@example.com",+                          subject = "hello",+                          at = sampleAt+                        }+                  )+          solveOutput o (initialRegs rmapped) wrappedEvent+            `shouldBe` (Nothing :: Maybe EmailCmd)++    it "preserves isSingleValuedSym" $ do+      isSingleValuedSym (withSymPred (rmapCo WrappedEvent emailDelivery))+        `shouldBe` True++  describe "dimapTransducer" $ do+    it "agrees with rmapCo . lmapCi on forward output" $ do+      let viaDimap = dimapTransducer unwrapCmd WrappedEvent emailDelivery+          viaSplit = rmapCo WrappedEvent (lmapCi unwrapCmd emailDelivery)+          input = WrappedCmd sampleEmailCmd+      fireFromInitial viaDimap input+        `shouldBe` fireFromInitial viaSplit input++  describe "lmapMaybeCi" $ do+    it "filters non-routed inputs (no edges fire)" $ do+      let routed = lmapMaybeCi router emailDelivery+      fireFromInitial routed OtherCmd `shouldBe` []++    it "passes routed inputs through" $ do+      let routed = lmapMaybeCi router emailDelivery+          fired = fireFromInitial routed (ToEmail sampleEmailCmd)+      length fired `shouldBe` 1+      map fst fired `shouldBe` [EmailSentVertex]++  describe "Profunctor SomeSymTransducer" $ do+    it "dimap on the wrapper agrees with dimapTransducer on the inner" $ do+      let viaWrapper =+            dimap unwrapCmd WrappedEvent (someSymTransducer emailDelivery)+          viaConcrete =+            dimapTransducer unwrapCmd WrappedEvent emailDelivery+          input = WrappedCmd sampleEmailCmd+          fromConcrete = fireOutputsOnly viaConcrete input+      case viaWrapper of+        SomeSymTransducer t -> fireOutputsOnly t input `shouldBe` fromConcrete++    it "fmap on the wrapper post-composes the output" $ do+      let mapped = fmap WrappedEvent (someSymTransducer emailDelivery)+          expected =+            [ [ WrappedEvent+                  ( EmailSent+                      EmailSentData+                        { recipient = "alice@example.com",+                          subject = "hello",+                          at = sampleAt+                        }+                  )+              ]+            ]+      case mapped of+        SomeSymTransducer t ->+          fireOutputsOnly t sampleEmailCmd `shouldBe` expected++-- * Hspec helpers ----------------------------------------------------------++-- | A loose 'errorCall' matcher: asserts the thrown 'ErrorCall'+-- contains the given substring. Hspec ships an 'errorCall' matcher+-- for exact match; the substring variant is useful when the message+-- is partially a runtime-formatted string.+errorCall' :: String -> Selector ErrorCall+errorCall' needle (ErrorCall msg) = needle `isInfixOf'` msg++isInfixOf' :: String -> String -> Bool+isInfixOf' needle haystack+  | length needle > length haystack = False+  | take (length needle) haystack == needle = True+  | otherwise = isInfixOf' needle (drop 1 haystack)
+ test/Keiki/RecomputeVerifySpec.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TemplateHaskell #-}+-- deriveAggregateCtors also emits an @is<Short>@ guard predicate per ctor,+-- which these fixtures do not all use.+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- | EP-47 — recompute-and-verify derived event outputs, tested against the+-- real (relaxed) 'Keiki.Core.solveOutput'.+--+-- An order-cart aggregate stores a /derived/ output field+-- @lineTotal = quantity * unitPrice@. Three groups:+--+--   (i)   round-trip — the derived-total event replays through 'applyEvents',+--         and a tampered total is rejected;+--   (ii)  determinism — over a grid of commands, every command round-trips to+--         exactly itself and distinct commands never collide on one event;+--   (iii) negative — a /hidden input/ (a command slot read only inside a+--         derived field) is still flagged at build time by 'checkHiddenInputs'.+--+-- (The EP-47 M1 prototype validated the same logic with a local function+-- before the core change; that is now subsumed by exercising the production+-- 'solveOutput'/'applyEvents' directly.)+module Keiki.RecomputeVerifySpec (spec) where++import Data.List (isInfixOf, nub)+import Data.Maybe (isNothing)+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic)+import Keiki.Builder ((.=))+import Keiki.Builder qualified as B+import Keiki.Core+  ( Edge (..),+    HiddenInputWarning (..),+    HsPred (..),+    Index,+    OutTerm,+    RegFile (..),+    SymTransducer (..),+    Update (..),+    applyEvents,+    checkHiddenInputs,+    evalOut,+    pack,+    solveOutput,+    (!),+    (.*),+  )+import Keiki.Generics (emptyRegFile)+import Keiki.Generics.TH (deriveAggregateCtors, deriveWireCtors)+import Test.Hspec++-- * Order-cart fixture --------------------------------------------------++data AddData = AddData {quantity :: Int, unitPrice :: Int}+  deriving (Eq, Show, Generic)++data CartCmd = AddLineItem AddData+  deriving (Eq, Show, Generic)++-- The event mirrors quantity/unitPrice and ALSO stores a derived total.+data AddedData = AddedData {quantity :: Int, unitPrice :: Int, lineTotal :: Int}+  deriving (Eq, Show, Generic)++data CartEvt = LineItemAdded AddedData+  deriving (Eq, Show, Generic)++type CartRegs = '[ '("quantity", Int), '("unitPrice", Int)]++data CartV = CartOpen+  deriving (Eq, Show, Enum, Bounded)++$(deriveAggregateCtors ''CartCmd ''CartRegs [("AddLineItem", "Add")])+$(deriveWireCtors ''CartEvt [("LineItemAdded", "Added")])++emptyCartRegs :: RegFile CartRegs+emptyCartRegs = emptyRegFile++-- The well-formed aggregate: quantity and unitPrice are plain command-field+-- projections in the event (the invertible fields that recover the command);+-- lineTotal is the redundant derived field @quantity * unitPrice@.+cart :: SymTransducer (HsPred CartRegs CartCmd) CartRegs CartV CartCmd CartEvt+cart = B.buildTransducer CartOpen emptyCartRegs (const True) do+  B.from CartOpen do+    B.onCmd inCtorAdd $ \d -> B.do+      B.slot @"quantity" .= d.quantity+      B.slot @"unitPrice" .= d.unitPrice+      B.emit+        wireAdded+        AddedTermFields+          { quantity = d.quantity,+            unitPrice = d.unitPrice,+            lineTotal = d.quantity .* d.unitPrice+          }+      B.goto CartOpen++-- The head output term of the cart edge, for the determinism group.+cartOut :: OutTerm CartRegs CartCmd CartEvt+cartOut = case edgesOut cart CartOpen of+  e : _ | o : _ <- output e -> o+  _ -> error "RecomputeVerifySpec: cart edge/output missing"++-- * A malformed variant: quantity hidden inside the derived field --------++data BadData = BadData {unitPrice :: Int, total :: Int}+  deriving (Eq, Show, Generic)++data BadEvt = BadAdded BadData+  deriving (Eq, Show, Generic)++$(deriveWireCtors ''BadEvt [("BadAdded", "Bad")])++-- The output recovers only unitPrice invertibly; quantity is read ONLY+-- inside the derived @total@ field, so the command cannot be recovered —+-- a genuine hidden input that checkHiddenInputs must still flag.+badOut :: OutTerm CartRegs CartCmd BadEvt+badOut =+  pack+    inCtorAdd+    wireBad+    ( B.toOutFields+        BadTermFields+          { unitPrice = inpAdd #unitPrice,+            total = inpAdd #quantity .* inpAdd #unitPrice+          }+    )++badCart :: SymTransducer (HsPred CartRegs CartCmd) CartRegs CartV CartCmd BadEvt+badCart =+  SymTransducer+    { edgesOut = \CartOpen ->+        [ Edge+            { guard = PInCtor inCtorAdd,+              update = UKeep,+              output = [badOut],+              target = CartOpen+            }+        ],+      initial = CartOpen,+      initialRegs = emptyCartRegs,+      isFinal = const True+    }++-- * A derived field that reads a REGISTER (not just command fields) -------++-- A `rate` register (state) and a Charge { qty } command. The event stores+-- qty (invertible) and a derived `amountDue = rate * qty`, where `rate` is+-- read from the register. This is the case where recompute-and-verify+-- depends on the register holding its emit-time value.+type RateRegs = '[ '("rate", Int)]++data ChargeCmdData = ChargeCmdData {qty :: Int}+  deriving (Eq, Show, Generic)++data RateCmd = Charge ChargeCmdData+  deriving (Eq, Show, Generic)++data ChargedData = ChargedData {qty :: Int, amountDue :: Int}+  deriving (Eq, Show, Generic)++data RateEvt = Charged ChargedData+  deriving (Eq, Show, Generic)++$(deriveAggregateCtors ''RateCmd ''RateRegs [("Charge", "Charge")])+$(deriveWireCtors ''RateEvt [("Charged", "Charged")])++-- amountDue = #rate * d.qty — a TArith over a register read and a command+-- field. qty is the invertible field that recovers the command; rate is+-- state (not a command slot), so there is no hidden input.+chargeOut :: OutTerm RateRegs RateCmd RateEvt+chargeOut =+  pack+    inCtorCharge+    wireCharged+    ( B.toOutFields+        ChargedTermFields+          { qty = inpCharge #qty,+            amountDue = B.reg @"rate" .* inpCharge #qty+          }+    )++ratedRegs :: Int -> RegFile RateRegs+ratedRegs r = RCons (Proxy @"rate") r RNil++spec :: Spec+spec = do+  describe "EP-47 (i): a derived-total event round-trips" $ do+    it "applyEvents replays LineItemAdded {3,7,21} and reconstructs the registers" $+      case applyEvents+        cart+        (initial cart, initialRegs cart)+        [LineItemAdded (AddedData 3 7 21)] of+        Just (s, regs) ->+          (s, regs ! (#quantity :: Index CartRegs Int), regs ! (#unitPrice :: Index CartRegs Int))+            `shouldBe` (CartOpen, 3, 7)+        Nothing -> expectationFailure "expected the derived-total event to round-trip"++    it "rejects a tampered lineTotal (3*7 = 21 /= 999)" $+      isNothing+        ( applyEvents+            cart+            (initial cart, initialRegs cart)+            [LineItemAdded (AddedData 3 7 999)]+        )+        `shouldBe` True++  describe "EP-47 (ii): event determines command (determinism preserved)" $ do+    let grid = [AddLineItem (AddData q u) | q <- [0 .. 5], u <- [0 .. 5]]+        emit c = evalOut cartOut emptyCartRegs c++    it "every command in the grid round-trips through solveOutput to itself" $+      [solveOutput cartOut emptyCartRegs (emit c) | c <- grid]+        `shouldBe` map Just grid++    it "distinct commands never collide on one observed event" $+      length (nub (map emit grid)) `shouldBe` length grid++  describe "EP-47 (iii): a hidden input still fails the build-time check" $ do+    it "checkHiddenInputs flags the well-formed cart with NO warning" $+      checkHiddenInputs cart `shouldBe` []++    it "checkHiddenInputs flags badCart: quantity read only inside the derived field" $ do+      let warnings = checkHiddenInputs badCart+      length warnings `shouldSatisfy` (>= 1)+      let reasons = map hiwReason warnings+      any (\r -> "AddLineItem" `isInfixOf` r && "quantity" `isInfixOf` r) reasons+        `shouldBe` True++  describe "EP-47 (iv): a register-reading derived field is verified against the registers" $ do+    -- This pins the documented limitation: recompute-and-verify of a derived+    -- field that reads a REGISTER depends on the register holding its+    -- emit-time value. That holds for a full reconstitute and for replay from+    -- a valid snapshot, but not for a synthetic mid-state with stale/empty+    -- registers. A plain TReg audit field, by contrast, is invertible and is+    -- NOT verified, so it round-trips regardless.+    let cmd = Charge (ChargeCmdData 3)+        charged = evalOut chargeOut (ratedRegs 10) cmd -- Charged { qty = 3, amountDue = 30 }+    it "round-trips when the register holds its emit-time value (rate = 10)" $+      solveOutput chargeOut (ratedRegs 10) charged `shouldBe` Just cmd++    it "is rejected when replayed against an inconsistent register file (rate = 99)" $+      -- amountDue recomputes as 99*3 = 297 /= the observed 30, so verification+      -- fails. (The command qty IS still recovered; only the derived field's+      -- forward recompute mismatches.)+      solveOutput chargeOut (ratedRegs 99) charged `shouldBe` Nothing++    it "a command-field-only derived field (cart lineTotal) is register-independent" $+      -- cartOut's lineTotal reads only command fields, so any register file+      -- works — contrast with the register-reading case above.+      solveOutput cartOut emptyCartRegs (LineItemAdded (AddedData 3 7 21))+        `shouldBe` Just (AddLineItem (AddData 3 7))
+ test/Keiki/Render/InspectorSpec.hs view
@@ -0,0 +1,204 @@+-- | Golden tests for "Keiki.Render.Inspector": the Markdown edge-detail+-- renderer. Pins the exact document produced for the real multi-edge+-- fixture 'Keiki.Fixtures.UserRegistration.userReg' — the same+-- transducer the Mermaid golden renders — so a reviewer can diff the+-- inspector document against the diagram and see they describe the same+-- edges.+module Keiki.Render.InspectorSpec (spec) where++import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Fixtures.UserRegistration (userReg)+import Keiki.Render.Inspector+  ( EdgeInspectorOptions (..),+    defaultEdgeInspectorOptions,+    renderEdgeInspector,+  )+import Test.Hspec++spec :: Spec+spec = do+  describe "renderEdgeInspector (default options)" $+    it "renders userReg to the canonical Markdown inspector block" $+      renderEdgeInspector defaultEdgeInspectorOptions userReg+        `shouldBe` userRegInspectorCanonical++  describe "renderEdgeInspector (includePrettyGuard)" $+    it "shows both the structural and the domain-readable guard" $+      renderEdgeInspector+        (defaultEdgeInspectorOptions {includePrettyGuard = True})+        userReg+        `shouldBe` userRegInspectorPrettyGuardCanonical++  describe "renderEdgeInspector (includeOutputFields)" $+    it "lists each output field's term positionally" $+      renderEdgeInspector+        (defaultEdgeInspectorOptions {includeOutputFields = True})+        userReg+        `shouldBe` userRegInspectorOutputFieldsCanonical++-- | The default inspector document for @userReg@: edge index, structural+-- guard, and written slots on; pretty guard and output fields off.+-- @Deleted@ has no outgoing edges, so it produces no section; the+-- @FulfillGDPRRequest@ edge from @RequiresConfirmation@ emits no event,+-- so its output renders the literal ε (U+03B5). Edge indices are the+-- 0-based @edgesOut@ positions (note the self-loop at index 1 and the+-- delete edge at index 2).+userRegInspectorCanonical :: Text+userRegInspectorCanonical =+  T.intercalate+    (T.pack "\n")+    [ "# Edge inspector",+      "",+      "### PotentialCustomer",+      "",+      "- **PotentialCustomer -> RequiresConfirmation**",+      "  - edge index: 0",+      "  - input: StartRegistration",+      "  - output: RegistrationStarted; ConfirmationEmailSent",+      "  - guard (structural): PInCtor",+      "  - written slots: registeredAt; confirmCode; email",+      "",+      "### RequiresConfirmation",+      "",+      "- **RequiresConfirmation -> Confirmed**",+      "  - edge index: 0",+      "  - input: ConfirmAccount",+      "  - output: AccountConfirmed",+      "  - guard (structural): PAnd PInCtor PEq",+      "  - written slots: confirmedAt",+      "- **RequiresConfirmation -> RequiresConfirmation**",+      "  - edge index: 1",+      "  - input: ResendConfirmation",+      "  - output: ConfirmationResent",+      "  - guard (structural): PInCtor",+      "  - written slots: registeredAt; confirmCode",+      "- **RequiresConfirmation -> Deleted**",+      "  - edge index: 2",+      "  - input: FulfillGDPRRequest",+      "  - output: \x03B5",+      "  - guard (structural): PInCtor",+      "  - written slots: deletedAt",+      "",+      "### Confirmed",+      "",+      "- **Confirmed -> Deleted**",+      "  - edge index: 0",+      "  - input: FulfillGDPRRequest",+      "  - output: AccountDeleted",+      "  - guard (structural): PInCtor",+      "  - written slots: deletedAt"+    ]++-- | With @includePrettyGuard = True@ each edge shows BOTH the structural+-- guard and the domain-readable guard (from+-- 'Keiki.Render.Pretty.prettyPred'). The contrast is the payoff: the+-- @ConfirmAccount@ edge reads @PAnd PInCtor PEq@ structurally and+-- @(ConfirmAccount && ConfirmAccount.confirmCode == confirmCode)@ pretty.+userRegInspectorPrettyGuardCanonical :: Text+userRegInspectorPrettyGuardCanonical =+  T.intercalate+    (T.pack "\n")+    [ "# Edge inspector",+      "",+      "### PotentialCustomer",+      "",+      "- **PotentialCustomer -> RequiresConfirmation**",+      "  - edge index: 0",+      "  - input: StartRegistration",+      "  - output: RegistrationStarted; ConfirmationEmailSent",+      "  - guard (structural): PInCtor",+      "  - guard (pretty): StartRegistration",+      "  - written slots: registeredAt; confirmCode; email",+      "",+      "### RequiresConfirmation",+      "",+      "- **RequiresConfirmation -> Confirmed**",+      "  - edge index: 0",+      "  - input: ConfirmAccount",+      "  - output: AccountConfirmed",+      "  - guard (structural): PAnd PInCtor PEq",+      "  - guard (pretty): (ConfirmAccount && ConfirmAccount.confirmCode == confirmCode)",+      "  - written slots: confirmedAt",+      "- **RequiresConfirmation -> RequiresConfirmation**",+      "  - edge index: 1",+      "  - input: ResendConfirmation",+      "  - output: ConfirmationResent",+      "  - guard (structural): PInCtor",+      "  - guard (pretty): ResendConfirmation",+      "  - written slots: registeredAt; confirmCode",+      "- **RequiresConfirmation -> Deleted**",+      "  - edge index: 2",+      "  - input: FulfillGDPRRequest",+      "  - output: \x03B5",+      "  - guard (structural): PInCtor",+      "  - guard (pretty): FulfillGDPRRequest",+      "  - written slots: deletedAt",+      "",+      "### Confirmed",+      "",+      "- **Confirmed -> Deleted**",+      "  - edge index: 0",+      "  - input: FulfillGDPRRequest",+      "  - output: AccountDeleted",+      "  - guard (structural): PInCtor",+      "  - guard (pretty): FulfillGDPRRequest",+      "  - written slots: deletedAt"+    ]++-- | With @includeOutputFields = True@ each edge that emits at least one+-- output field gains an @output fields@ bullet listing each field's term+-- positionally (via 'Keiki.Render.Pretty.prettyTerm'), grouped by output+-- constructor. Fields are labelled by position only — 'WireCtor' carries+-- no field names. The ε-edge (no output) gets no such bullet. Note the+-- terms mix input-field reads (@StartRegistration.email@) and register+-- reads (@email@).+userRegInspectorOutputFieldsCanonical :: Text+userRegInspectorOutputFieldsCanonical =+  T.intercalate+    (T.pack "\n")+    [ "# Edge inspector",+      "",+      "### PotentialCustomer",+      "",+      "- **PotentialCustomer -> RequiresConfirmation**",+      "  - edge index: 0",+      "  - input: StartRegistration",+      "  - output: RegistrationStarted; ConfirmationEmailSent",+      "  - output fields: RegistrationStarted[field 0: StartRegistration.email; field 1: StartRegistration.confirmCode; field 2: StartRegistration.at]; ConfirmationEmailSent[field 0: StartRegistration.email]",+      "  - guard (structural): PInCtor",+      "  - written slots: registeredAt; confirmCode; email",+      "",+      "### RequiresConfirmation",+      "",+      "- **RequiresConfirmation -> Confirmed**",+      "  - edge index: 0",+      "  - input: ConfirmAccount",+      "  - output: AccountConfirmed",+      "  - output fields: AccountConfirmed[field 0: email; field 1: ConfirmAccount.confirmCode; field 2: ConfirmAccount.at]",+      "  - guard (structural): PAnd PInCtor PEq",+      "  - written slots: confirmedAt",+      "- **RequiresConfirmation -> RequiresConfirmation**",+      "  - edge index: 1",+      "  - input: ResendConfirmation",+      "  - output: ConfirmationResent",+      "  - output fields: ConfirmationResent[field 0: email; field 1: ResendConfirmation.code; field 2: ResendConfirmation.at]",+      "  - guard (structural): PInCtor",+      "  - written slots: registeredAt; confirmCode",+      "- **RequiresConfirmation -> Deleted**",+      "  - edge index: 2",+      "  - input: FulfillGDPRRequest",+      "  - output: \x03B5",+      "  - guard (structural): PInCtor",+      "  - written slots: deletedAt",+      "",+      "### Confirmed",+      "",+      "- **Confirmed -> Deleted**",+      "  - edge index: 0",+      "  - input: FulfillGDPRRequest",+      "  - output: AccountDeleted",+      "  - output fields: AccountDeleted[field 0: email; field 1: FulfillGDPRRequest.at]",+      "  - guard (structural): PInCtor",+      "  - written slots: deletedAt"+    ]
+ test/Keiki/Render/MarkdownSpec.hs view
@@ -0,0 +1,137 @@+-- | Tests for "Keiki.Render.Markdown" (EP-65 M2).+--+-- Exercises 'replaceMarkdownDiagramBlock': it rewrites exactly the span+-- between a matched pair of @\<!-- ns: id begin/end --\>@ markers with a+-- normalized fenced block, preserves every byte outside the markers,+-- reports a clear error when a marker is missing or duplicated, and is+-- idempotent.+--+-- See @docs/plans/65-mermaid-diagram-atlas-sections-and-markdown-marker-replacement-helper.md@.+module Keiki.Render.MarkdownSpec (spec) where++import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Render.Markdown+  ( MarkdownDiagramBlock (..),+    MarkdownDiagramError (..),+    replaceMarkdownDiagramBlock,+  )+import Test.Hspec++spec :: Spec+spec = do+  describe "replaceMarkdownDiagramBlock (happy path)" $ do+    it "replaces only the marked span and preserves the markers" $+      replaceMarkdownDiagramBlock newBlock inputDoc+        `shouldBe` Right expectedDoc++    it "preserves the prose above and below byte-for-byte" $+      case replaceMarkdownDiagramBlock newBlock inputDoc of+        Right out -> do+          T.isPrefixOf (T.pack "# Architecture\n\nSome prose above.") out+            `shouldBe` True+          T.isSuffixOf (T.pack "Some prose below.") out `shouldBe` True+        Left err -> expectationFailure ("unexpected error: " <> show err)++    it "is idempotent: replacing the already-normalized block reproduces it" $+      (replaceMarkdownDiagramBlock newBlock expectedDoc)+        `shouldBe` Right expectedDoc++  describe "replaceMarkdownDiagramBlock (errors)" $ do+    it "reports the expected begin marker when it is absent" $+      replaceMarkdownDiagramBlock newBlock (T.pack "no markers here\n")+        `shouldBe` Left (MissingBeginMarker (T.pack "<!-- seihou: incident-command begin -->"))++    it "reports the expected end marker when only the begin is present" $+      replaceMarkdownDiagramBlock newBlock beginOnlyDoc+        `shouldBe` Left (MissingEndMarker (T.pack "<!-- seihou: incident-command end -->"))++    it "fails deterministically when the begin marker is duplicated" $+      replaceMarkdownDiagramBlock newBlock duplicateBeginDoc+        `shouldBe` Left (DuplicateMarker (T.pack "<!-- seihou: incident-command begin -->") 2)++    it "fails deterministically when the end marker is duplicated" $+      replaceMarkdownDiagramBlock newBlock duplicateEndDoc+        `shouldBe` Left (DuplicateMarker (T.pack "<!-- seihou: incident-command end -->") 2)++-- | The block to splice; its content ends in a newline to exercise the+-- trailing-newline stripping that makes the helper idempotent.+newBlock :: MarkdownDiagramBlock+newBlock =+  MarkdownDiagramBlock+    { blockNamespace = T.pack "seihou",+      blockId = T.pack "incident-command",+      blockLanguage = T.pack "mermaid",+      blockContent = T.pack "stateDiagram-v2\n    [*] --> Open\n"+    }++-- | A hand-maintained document with prose around a stale diagram.+inputDoc :: Text+inputDoc =+  T.intercalate+    (T.pack "\n")+    [ "# Architecture",+      "",+      "Some prose above.",+      "",+      "<!-- seihou: incident-command begin -->",+      "```mermaid",+      "OLD DIAGRAM",+      "```",+      "<!-- seihou: incident-command end -->",+      "",+      "Some prose below."+    ]++-- | 'inputDoc' after replacing the marked block with 'newBlock'. Only the+-- span between the markers changed; the markers and surrounding prose are+-- byte-identical, and the trailing newline in 'blockContent' is stripped+-- before the closing fence.+expectedDoc :: Text+expectedDoc =+  T.intercalate+    (T.pack "\n")+    [ "# Architecture",+      "",+      "Some prose above.",+      "",+      "<!-- seihou: incident-command begin -->",+      "```mermaid",+      "stateDiagram-v2",+      "    [*] --> Open",+      "```",+      "<!-- seihou: incident-command end -->",+      "",+      "Some prose below."+    ]++-- | A document with the begin marker but no matching end marker.+beginOnlyDoc :: Text+beginOnlyDoc =+  T.intercalate+    (T.pack "\n")+    [ "<!-- seihou: incident-command begin -->",+      "```mermaid",+      "OLD DIAGRAM",+      "```"+    ]++-- | A document whose begin marker appears twice.+duplicateBeginDoc :: Text+duplicateBeginDoc =+  T.intercalate+    (T.pack "\n")+    [ "<!-- seihou: incident-command begin -->",+      "<!-- seihou: incident-command begin -->",+      "<!-- seihou: incident-command end -->"+    ]++-- | A document whose end marker appears twice.+duplicateEndDoc :: Text+duplicateEndDoc =+  T.intercalate+    (T.pack "\n")+    [ "<!-- seihou: incident-command begin -->",+      "<!-- seihou: incident-command end -->",+      "<!-- seihou: incident-command end -->"+    ]
+ test/Keiki/Render/MermaidSpec.hs view
@@ -0,0 +1,832 @@+-- | Regression tests for "Keiki.Render.Mermaid".+--+-- Pins the canonical Mermaid 'stateDiagram-v2' blocks produced by+-- 'toMermaid' over 'Keiki.Fixtures.UserRegistration.userReg' (EP-30),+-- 'toMermaidComposite' over the @AlertSource ⨾ EmailDelivery@+-- composite from "Keiki.CompositionSpec" (EP-31),+-- 'toMermaidCompositeNested' over the same composite (EP-32),+-- 'toMermaidAlternative' over @alternative emailDelivery pinger@+-- from "Keiki.CompositionAlternativeSpec" (EP-33),+-- 'toMermaidFeedback1' over @feedback1 toggleAgg togglePolicy@ from+-- "Keiki.CompositionFeedback1Spec" (EP-33), and 'toMermaidCompose3' /+-- 'toMermaidCompose3Nested' over the inline three-toy fixture+-- @toy3deep = toy1 \`compose\` (toy2 \`compose\` toy3)@ defined at+-- the bottom of this file (EP-35), so that any accidental formatting+-- drift surfaces in CI.+--+-- See:+--+--   * @docs/plans/30-mermaid-renderer-for-single-symtransducer-canonical-example-diagrams.md@+--     — single-transducer renderer.+--   * @docs/plans/31-mermaid-rendering-for-composite-symtransducers.md@+--     — composite renderer (flat cross-product, Shape A).+--   * @docs/plans/32-shape-b-nested-subgraph-mermaid-rendering-for-larger-composites.md@+--     — nested-subgraph renderer (Shape B).+--   * @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@+--     — shape-aware renderers for `alternative` (parallel arms) and+--     `feedback1` (flat 3-deep cross-product).+--   * @docs/plans/35-mermaid-renderer-for-right-associative-3-deep-compose-composites.md@+--     — right-associative 3-deep compose renderers (flat + one-level+--     nested) and the synthetic three-toy fixture.+module Keiki.Render.MermaidSpec (spec) where++import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Composition (Composite, compose)+import Keiki.CompositionAlternativeSpec (pinger)+import Keiki.CompositionFeedback1Spec (toggleAgg, togglePolicy)+import Keiki.CompositionSpec (alertSource)+import Keiki.Core+  ( Edge (..),+    HsPred (..),+    InCtor (..),+    OutFields (..),+    RegFile (..),+    SymTransducer (..),+    Update (..),+    WireCtor (..),+    pack,+  )+import Keiki.Fixtures.EmailDelivery (emailDelivery)+import Keiki.Fixtures.UserRegistration (Vertex (..), userReg)+import Keiki.Render.Mermaid+  ( AtlasKindDisplay (..),+    MermaidAtlasOptions (..),+    MermaidGuardMode (..),+    MermaidLabelLayout (..),+    MermaidOptions (..),+    MermaidOutputLayout (..),+    MermaidSection (..),+    MermaidSectionKind (..),+    MermaidStateLabels (..),+    defaultMermaidAtlasOptions,+    defaultMermaidOptions,+    duplicateStateIds,+    toMermaid,+    toMermaidAlternative,+    toMermaidAtlas,+    toMermaidAtlasWith,+    toMermaidCompose3,+    toMermaidCompose3Nested,+    toMermaidComposite,+    toMermaidCompositeNested,+    toMermaidFeedback1,+    toMermaidWith,+    toMermaidWithLabels,+    vertexLabel,+  )+import Test.Hspec++spec :: Spec+spec = do+  describe "toMermaid (single SymTransducer)" $+    it "renders userReg to the canonical stateDiagram-v2 block" $+      toMermaid userReg `shouldBe` userRegCanonical++  describe "toMermaidComposite (composite SymTransducer)" $+    it "renders the AlertSource ⨾ EmailDelivery pipeline" $+      toMermaidComposite (compose alertSource emailDelivery)+        `shouldBe` alertEmailCompositeCanonical++  describe "toMermaidCompositeNested (composite SymTransducer)" $+    it "renders the AlertSource ⨾ EmailDelivery pipeline in nested form" $+      toMermaidCompositeNested (compose alertSource emailDelivery)+        `shouldBe` alertEmailCompositeNestedCanonical++  describe "toMermaidAlternative (alternative composite)" $+    it "renders alternative emailDelivery pinger as parallel arms" $+      toMermaidAlternative emailDelivery pinger+        `shouldBe` emailPingerAltCanonical++  describe "toMermaidFeedback1 (feedback1 composite)" $+    it "renders feedback1 toggleAgg togglePolicy as flat 3-deep cross-product" $+      toMermaidFeedback1 toggleAgg togglePolicy+        `shouldBe` toggleFeedback1Canonical++  describe "toMermaidCompose3 (right-associative 3-deep compose)" $+    it "renders the toy1 ⨾ (toy2 ⨾ toy3) flat block" $+      toMermaidCompose3 toy3deep `shouldBe` toy3deepFlatCanonical++  describe "toMermaidCompose3Nested (right-associative 3-deep compose)" $+    it "renders the toy1 ⨾ (toy2 ⨾ toy3) one-level nested block" $+      toMermaidCompose3Nested toy3deep `shouldBe` toy3deepNestedCanonical++  -- EP-50 M3: the default must stay byte-identical to today (the+  -- guard-free pedagogy in deriving-lifecycle-transitions.md depends on+  -- it). The pre-existing "toMermaid (single SymTransducer)" golden above+  -- is the primary proof; this guards against toMermaid and toMermaidWith+  -- diverging under a future refactor.+  describe "toMermaidWith defaultMermaidOptions (byte-identical default)" $+    it "equals toMermaid userReg exactly" $+      toMermaidWith defaultMermaidOptions userReg `shouldBe` toMermaid userReg++  describe "toMermaidWith (annotated edge summary)" $+    it "renders userReg with written-slot and guard-summary suffixes" $+      toMermaidWith+        (defaultMermaidOptions {showWrittenSlots = True, showGuardSummary = True})+        userReg+        `shouldBe` userRegAnnotatedCanonical++  describe "toMermaidWith (MermaidGuardPretty, EP-61)" $+    it "renders userReg guards in domain-readable form" $+      toMermaidWith+        (defaultMermaidOptions {guardMode = MermaidGuardPretty})+        userReg+        `shouldBe` userRegPrettyGuardCanonical++  describe "toMermaidWith (multiline label layout, EP-63)" $+    it "renders userReg labels with <br/>-separated segments" $+      toMermaidWith+        ( defaultMermaidOptions+            { showWrittenSlots = True,+              showGuardSummary = True,+              labelLayout = MermaidLabelMultiline+            }+        )+        userReg+        `shouldBe` userRegMultilineCanonical++  describe "toMermaidWith (written-slot truncation, EP-63)" $+    it "truncates a long written-slot list with +N more" $+      toMermaidWith+        ( defaultMermaidOptions+            { showWrittenSlots = True,+              maxInlineWrittenSlots = Just 2+            }+        )+        userReg+        `shouldBe` userRegSlotTruncCanonical++  describe "toMermaidWith (guard-width truncation, EP-63)" $+    it "truncates an over-long guard segment with an ellipsis" $+      toMermaidWith+        ( defaultMermaidOptions+            { showGuardSummary = True,+              maxInlineGuardWidth = Just 10+            }+        )+        userReg+        `shouldBe` userRegGuardTruncCanonical++  describe "toMermaidWith (MermaidOutputSemicolon default, EP-63)" $+    it "renders multiEvt with the length-based default output layout" $+      toMermaid multiEvt `shouldBe` multiEvtSemicolonCanonical++  describe "toMermaidWith (MermaidOutputMultiline, EP-63)" $+    it "renders every multi-event edge one event per line" $+      toMermaidWith+        (defaultMermaidOptions {outputLayout = MermaidOutputMultiline})+        multiEvt+        `shouldBe` multiEvtMultilineCanonical++  describe "toMermaidWith (MermaidOutputCounted, EP-63)" $+    it "renders multi-event edges as an N events count" $+      toMermaidWith+        (defaultMermaidOptions {outputLayout = MermaidOutputCounted})+        multiEvt+        `shouldBe` multiEvtCountedCanonical++  describe "toMermaidWithLabels (stable ASCII ids, spaced display labels, EP-64)" $+    it "renders userReg with friendly labels and stable ids" $+      toMermaidWithLabels defaultMermaidOptions userRegLabels userReg+        `shouldBe` userRegLabeledCanonical++  describe "toMermaidWithLabels (id == display is byte-identical, EP-64)" $+    it "equals toMermaidWith when stateId == stateDisplayLabel" $+      toMermaidWithLabels+        defaultMermaidOptions+        (MermaidStateLabels {stateId = vertexLabel, stateDisplayLabel = vertexLabel})+        userReg+        `shouldBe` toMermaidWith defaultMermaidOptions userReg++  describe "duplicateStateIds (EP-64)" $ do+    it "is empty for a unique-id labels record" $+      duplicateStateIds userRegLabels userReg `shouldBe` []+    it "reports the colliding id for a clashing labels record" $+      duplicateStateIds collidingLabels userReg+        `shouldBe` [T.pack "X"]++  describe "toMermaidAtlas (multi-diagram document)" $+    it "assembles two labelled diagrams into one document" $+      toMermaidAtlas+        [ (T.pack "User registration", toMermaid userReg),+          (T.pack "Alert \x2A3E Email", toMermaidComposite (compose alertSource emailDelivery))+        ]+        `shouldBe` atlasCanonical++  describe "toMermaidAtlasWith (typed sections, EP-65)" $+    it "distinguishes kinds and emits markers keyed by sectionId" $+      toMermaidAtlasWith+        ( defaultMermaidAtlasOptions+            { atlasTitle = Just (T.pack "Seihou diagrams"),+              atlasShowSectionKind = KindAsComment,+              atlasWrapMarkers = Just (T.pack "seihou")+            }+        )+        [ MermaidSection+            (T.pack "incident-command")+            (T.pack "Incident Command")+            AggregateDiagram+            (toMermaid userReg),+          MermaidSection+            (T.pack "dispatch")+            (T.pack "Dispatch")+            ProcessManagerDiagram+            (toMermaidComposite (compose alertSource emailDelivery))+        ]+        `shouldBe` typedAtlasCanonical++-- | The canonical Mermaid block for @userReg@, mirrored verbatim from+-- the aggregate's diagram in @docs/guide/diagrams/user-registration.md@.+-- Stored inline (not in an external fixture file) so a formatting change+-- requires touching this file alongside the producer change.+userRegCanonical :: Text+userRegCanonical =+  unlinesNoTrail+    -- EP-19 M7: the entrance is now a single length-2 multi-event edge;+    -- the renderer's length-based switchover formats it with a "; "+    -- separator (per the design note's Mermaid section).+    [ "stateDiagram-v2",+      "    [*] --> PotentialCustomer",+      "    PotentialCustomer --> RequiresConfirmation : StartRegistration / RegistrationStarted; ConfirmationEmailSent",+      "    RequiresConfirmation --> Confirmed : ConfirmAccount / AccountConfirmed",+      "    RequiresConfirmation --> RequiresConfirmation : ResendConfirmation / ConfirmationResent",+      "    RequiresConfirmation --> Deleted : FulfillGDPRRequest / \x03B5",+      "    Confirmed --> Deleted : FulfillGDPRRequest / AccountDeleted",+      "    Deleted --> [*]"+    ]+  where+    unlinesNoTrail = T.intercalate (T.pack "\n")++-- | EP-50: the canonical block for @userReg@ rendered with both summary+-- flags on (@MermaidOptions True True@). Differs from 'userRegCanonical'+-- only by the bracketed @[w: …; g: …]@ suffixes. Captured verbatim from+-- the renderer (the slot order is the @UCombine@ nesting order, and each+-- guard is the actual 'HsPred' shape @onCmd@ produced — a bare 'PInCtor'+-- except where 'requireEq' added a 'PEq', giving @PAnd PInCtor PEq@).+userRegAnnotatedCanonical :: Text+userRegAnnotatedCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> PotentialCustomer",+      "    PotentialCustomer --> RequiresConfirmation : StartRegistration / RegistrationStarted; ConfirmationEmailSent [w: registeredAt; confirmCode; email; g: PInCtor]",+      "    RequiresConfirmation --> Confirmed : ConfirmAccount / AccountConfirmed [w: confirmedAt; g: PAnd PInCtor PEq]",+      "    RequiresConfirmation --> RequiresConfirmation : ResendConfirmation / ConfirmationResent [w: registeredAt; confirmCode; g: PInCtor]",+      "    RequiresConfirmation --> Deleted : FulfillGDPRRequest / \x03B5 [w: deletedAt; g: PInCtor]",+      "    Confirmed --> Deleted : FulfillGDPRRequest / AccountDeleted [w: deletedAt; g: PInCtor]",+      "    Deleted --> [*]"+    ]++-- | EP-61: the canonical block for @userReg@ rendered with+-- @guardMode = MermaidGuardPretty@ and 'showWrittenSlots' left at its+-- default 'False', so each label carries only a domain-readable+-- @[g: …]@ segment. Differs from 'userRegAnnotatedCanonical' by+-- rendering real names — @ConfirmAccount@, @confirmCode@ — instead of+-- the structural constructor-tag walk (@PAnd PInCtor PEq@). Captured+-- verbatim from the renderer.+userRegPrettyGuardCanonical :: Text+userRegPrettyGuardCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> PotentialCustomer",+      "    PotentialCustomer --> RequiresConfirmation : StartRegistration / RegistrationStarted; ConfirmationEmailSent [g: StartRegistration]",+      "    RequiresConfirmation --> Confirmed : ConfirmAccount / AccountConfirmed [g: (ConfirmAccount && ConfirmAccount.confirmCode == confirmCode)]",+      "    RequiresConfirmation --> RequiresConfirmation : ResendConfirmation / ConfirmationResent [g: ResendConfirmation]",+      "    RequiresConfirmation --> Deleted : FulfillGDPRRequest / \x03B5 [g: FulfillGDPRRequest]",+      "    Confirmed --> Deleted : FulfillGDPRRequest / AccountDeleted [g: FulfillGDPRRequest]",+      "    Deleted --> [*]"+    ]++-- | EP-63: @userReg@ rendered with both summary flags on and+-- @labelLayout = MermaidLabelMultiline@. Same per-edge content as+-- 'userRegAnnotatedCanonical', but the bracketed inline suffix is replaced+-- by @<br/>@-separated segments: the @command / event@ base on the first+-- line, the @w: …@ segment next, the @g: …@ segment last. The 2-event+-- output @RegistrationStarted; ConfirmationEmailSent@ keeps its @;@+-- separator because that is the base segment's own (length-based) output+-- rendering, not a label segment.+userRegMultilineCanonical :: Text+userRegMultilineCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> PotentialCustomer",+      "    PotentialCustomer --> RequiresConfirmation : StartRegistration / RegistrationStarted; ConfirmationEmailSent<br/>w: registeredAt; confirmCode; email<br/>g: PInCtor",+      "    RequiresConfirmation --> Confirmed : ConfirmAccount / AccountConfirmed<br/>w: confirmedAt<br/>g: PAnd PInCtor PEq",+      "    RequiresConfirmation --> RequiresConfirmation : ResendConfirmation / ConfirmationResent<br/>w: registeredAt; confirmCode<br/>g: PInCtor",+      "    RequiresConfirmation --> Deleted : FulfillGDPRRequest / \x03B5<br/>w: deletedAt<br/>g: PInCtor",+      "    Confirmed --> Deleted : FulfillGDPRRequest / AccountDeleted<br/>w: deletedAt<br/>g: PInCtor",+      "    Deleted --> [*]"+    ]++-- | EP-63: @userReg@ rendered with @showWrittenSlots = True@ and+-- @maxInlineWrittenSlots = Just 2@. The only edge writing more than two+-- slots is @StartRegistration@ (three slots), which truncates to the first+-- two followed by a single @+1 more@ token; every other edge writes two or+-- fewer slots and is unchanged.+userRegSlotTruncCanonical :: Text+userRegSlotTruncCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> PotentialCustomer",+      "    PotentialCustomer --> RequiresConfirmation : StartRegistration / RegistrationStarted; ConfirmationEmailSent [w: registeredAt; confirmCode; +1 more]",+      "    RequiresConfirmation --> Confirmed : ConfirmAccount / AccountConfirmed [w: confirmedAt]",+      "    RequiresConfirmation --> RequiresConfirmation : ResendConfirmation / ConfirmationResent [w: registeredAt; confirmCode]",+      "    RequiresConfirmation --> Deleted : FulfillGDPRRequest / \x03B5 [w: deletedAt]",+      "    Confirmed --> Deleted : FulfillGDPRRequest / AccountDeleted [w: deletedAt]",+      "    Deleted --> [*]"+    ]++-- | EP-63: @userReg@ rendered with @showGuardSummary = True@ and+-- @maxInlineGuardWidth = Just 10@. The only guard whose structural text+-- exceeds ten characters is @ConfirmAccount@'s @PAnd PInCtor PEq@ (length+-- 16), truncated to the first ten characters plus the ellipsis @…@. The+-- other guards (@PInCtor@, length 7) are within the width and unchanged.+userRegGuardTruncCanonical :: Text+userRegGuardTruncCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> PotentialCustomer",+      "    PotentialCustomer --> RequiresConfirmation : StartRegistration / RegistrationStarted; ConfirmationEmailSent [g: PInCtor]",+      "    RequiresConfirmation --> Confirmed : ConfirmAccount / AccountConfirmed [g: PAnd PInCt\x2026]",+      "    RequiresConfirmation --> RequiresConfirmation : ResendConfirmation / ConfirmationResent [g: PInCtor]",+      "    RequiresConfirmation --> Deleted : FulfillGDPRRequest / \x03B5 [g: PInCtor]",+      "    Confirmed --> Deleted : FulfillGDPRRequest / AccountDeleted [g: PInCtor]",+      "    Deleted --> [*]"+    ]++-- | EP-63: the @multiEvt@ fixture (defined at the bottom of this file)+-- rendered with the default @outputLayout = MermaidOutputSemicolon@. The+-- 3-event edge joins with @<br/>@ (three or more events), the 2-event edge+-- joins with @;@ — exactly the renderer's historical length-based+-- behaviour, so @toMermaid multiEvt@ pins it.+multiEvtSemicolonCanonical :: Text+multiEvtSemicolonCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> MS0",+      "    MS0 --> MS1 : Go / A<br/>B<br/>C",+      "    MS1 --> MS2 : Go / A; B",+      "    MS2 --> [*]"+    ]++-- | EP-63: @multiEvt@ rendered with @outputLayout =+-- MermaidOutputMultiline@. Every multi-event edge is one event per line+-- regardless of count, so the 2-event edge becomes @A<br/>B@ (unlike the+-- default's @A; B@) and the 3-event edge is unchanged from the default.+multiEvtMultilineCanonical :: Text+multiEvtMultilineCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> MS0",+      "    MS0 --> MS1 : Go / A<br/>B<br/>C",+      "    MS1 --> MS2 : Go / A<br/>B",+      "    MS2 --> [*]"+    ]++-- | EP-63: @multiEvt@ rendered with @outputLayout =+-- MermaidOutputCounted@. Each multi-event edge collapses to an @N events@+-- count.+multiEvtCountedCanonical :: Text+multiEvtCountedCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> MS0",+      "    MS0 --> MS1 : Go / 3 events",+      "    MS1 --> MS2 : Go / 2 events",+      "    MS2 --> [*]"+    ]++-- | EP-64: a labels record mapping each @userReg@ 'Vertex' to its+-- @show@-derived stable ASCII id and a friendly spaced display label.+-- @Confirmed@ and @Deleted@ map to display labels equal to their ids, so+-- they get no @state \"…\" as …@ declaration; @PotentialCustomer@ and+-- @RequiresConfirmation@ get spaced labels and therefore declarations.+userRegLabels :: MermaidStateLabels Vertex+userRegLabels =+  MermaidStateLabels+    { stateId = T.pack . show,+      stateDisplayLabel = \case+        PotentialCustomer -> T.pack "Potential Customer"+        RequiresConfirmation -> T.pack "Requires Confirmation"+        Confirmed -> T.pack "Confirmed"+        Deleted -> T.pack "Deleted"+    }++-- | EP-64: a deliberately broken labels record collapsing every+-- 'Vertex' onto the single id @\"X\"@, so 'duplicateStateIds' reports+-- @\"X\"@ once.+collidingLabels :: MermaidStateLabels Vertex+collidingLabels =+  MermaidStateLabels+    { stateId = const (T.pack "X"),+      stateDisplayLabel = T.pack . show+    }++-- | EP-64: @userReg@ rendered by 'toMermaidWithLabels' with+-- 'userRegLabels'. Two @state \"…\" as …@ declarations (for the two+-- spaced labels) precede the initial-state line; every transition arrow+-- still uses the stable ASCII id, so the topology below the declarations+-- is byte-identical to 'userRegCanonical'.+userRegLabeledCanonical :: Text+userRegLabeledCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    state \"Potential Customer\" as PotentialCustomer",+      "    state \"Requires Confirmation\" as RequiresConfirmation",+      "    [*] --> PotentialCustomer",+      "    PotentialCustomer --> RequiresConfirmation : StartRegistration / RegistrationStarted; ConfirmationEmailSent",+      "    RequiresConfirmation --> Confirmed : ConfirmAccount / AccountConfirmed",+      "    RequiresConfirmation --> RequiresConfirmation : ResendConfirmation / ConfirmationResent",+      "    RequiresConfirmation --> Deleted : FulfillGDPRRequest / \x03B5",+      "    Confirmed --> Deleted : FulfillGDPRRequest / AccountDeleted",+      "    Deleted --> [*]"+    ]++-- | EP-50: the canonical atlas document for @userReg@ + the+-- @AlertSource ⨾ EmailDelivery@ composite. Built from the same canonical+-- diagram blocks the other goldens pin, wrapped in the atlas format+-- ('toMermaidAtlas': a @## @ heading then a fenced @mermaid@ block per+-- section, sections joined by a blank line) — so this golden pins the+-- atlas wrapping/joining independently of the diagram contents.+atlasCanonical :: Text+atlasCanonical =+  T.intercalate+    (T.pack "\n\n")+    [ T.pack "## User registration\n\n```mermaid\n"+        <> userRegCanonical+        <> T.pack "\n```",+      T.pack "## Alert \x2A3E Email\n\n```mermaid\n"+        <> alertEmailCompositeCanonical+        <> T.pack "\n```"+    ]++-- | EP-65: the canonical typed-atlas document. Two sections — an+-- aggregate and a process-manager — each labelled with an HTML-comment+-- kind line and wrapped in @seihou: {sectionId}@ begin/end markers, under a+-- top-level @# Seihou diagrams@ title. Built from the same canonical+-- diagram blocks the other goldens pin, so a future diagram change forces+-- an update here too. Exercises 'atlasTitle', 'KindAsComment',+-- 'atlasWrapMarkers', and the marker-id = 'sectionId' contract that ties+-- the atlas to "Keiki.Render.Markdown".+typedAtlasCanonical :: Text+typedAtlasCanonical =+  T.concat+    [ T.pack "# Seihou diagrams\n\n",+      T.pack "## Incident Command\n\n",+      T.pack "<!-- kind: Aggregate -->\n\n",+      T.pack "<!-- seihou: incident-command begin -->\n",+      T.pack "```mermaid\n",+      userRegCanonical,+      T.pack "\n```",+      T.pack "\n<!-- seihou: incident-command end -->",+      T.pack "\n\n",+      T.pack "## Dispatch\n\n",+      T.pack "<!-- kind: Process manager -->\n\n",+      T.pack "<!-- seihou: dispatch begin -->\n",+      T.pack "```mermaid\n",+      alertEmailCompositeCanonical,+      T.pack "\n```",+      T.pack "\n<!-- seihou: dispatch end -->"+    ]++-- | The canonical Mermaid block for the @AlertSource ⨾ EmailDelivery@+-- composite, mirrored verbatim from the diagram in+-- @docs/guide/diagrams/composite-alert-email.md@. Three lines: the+-- initial-state marker pointing at @Composite AlertQuiescent+-- EmailPending@, the single cross-product edge that advances both+-- component vertices in one step, and the final-state marker for the+-- terminal composite vertex. The other two reachable composite+-- vertices have no outgoing edges and are not final, so the renderer+-- omits them (same convention as 'toMermaid').+alertEmailCompositeCanonical :: Text+alertEmailCompositeCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> AlertQuiescent_EmailPending",+      "    AlertQuiescent_EmailPending --> AlertEmitted_EmailSentVertex : TriggerAlert / EmailSent",+      "    AlertEmitted_EmailSentVertex --> [*]"+    ]++-- | The canonical Mermaid block for the same composite under+-- 'toMermaidCompositeNested' (Shape B). Differences from+-- 'alertEmailCompositeCanonical': the body adds two+-- @state AlertQuiescent { … } / state AlertEmitted { … }@ blocks+-- (between the initial-state line and the edge line) listing every+-- composite vertex grouped under its outer @s1@ parent. The+-- cross-cutting transition and the final-state line are emitted at+-- the top level using the same flat+-- @\<show s1\>_\<show s2\>@ identifiers; no Mermaid+-- @Outer.Inner@ dotted syntax is used. See+-- @docs/guide/diagrams/composite-alert-email-nested.md@.+alertEmailCompositeNestedCanonical :: Text+alertEmailCompositeNestedCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> AlertQuiescent_EmailPending",+      "    state AlertQuiescent {",+      "        AlertQuiescent_EmailPending",+      "        AlertQuiescent_EmailSentVertex",+      "    }",+      "    state AlertEmitted {",+      "        AlertEmitted_EmailPending",+      "        AlertEmitted_EmailSentVertex",+      "    }",+      "    AlertQuiescent_EmailPending --> AlertEmitted_EmailSentVertex : TriggerAlert / EmailSent",+      "    AlertEmitted_EmailSentVertex --> [*]"+    ]++-- | The canonical Mermaid block for @toMermaidAlternative+-- emailDelivery pinger@. Two top-level @[*] -->@ initial markers,+-- one for each arm; two named @state … { … }@ blocks holding each+-- arm's edges; two top-level @--> [*]@ final markers. Mirrors the+-- diagram in+-- @docs/guide/diagrams/composite-email-pinger-alternative.md@.+emailPingerAltCanonical :: Text+emailPingerAltCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> EmailPending",+      "    [*] --> PingIdle",+      "    state LeftArm {",+      "        EmailPending --> EmailSentVertex : SendEmail / EmailSent",+      "    }",+      "    state RightArm {",+      "        PingIdle --> PingDone : Ping / Pong",+      "    }",+      "    EmailSentVertex --> [*]",+      "    PingDone --> [*]"+    ]++-- | The canonical Mermaid block for @toMermaidFeedback1 toggleAgg+-- togglePolicy@. Flat 3-deep cross-product labels+-- @\<outer\>_\<policy\>_\<inner\>@. All four composite vertices+-- appear because the cascade fires at every enumerated vertex+-- (the policy + inner-toggle synchronisation is independent of+-- which vertex the outer toggle currently occupies), and both+-- 'toggleAgg' and 'togglePolicy' use @isFinal = const True@ so+-- every composite vertex is final. Two of the four (the+-- @Off_Pol_On@ / @On_Pol_Off@ pair) are unreachable from the+-- initial vertex; the renderer surfaces them anyway because the+-- enumeration walks the static cross-product. See the diagram in+-- @docs/guide/diagrams/composite-toggle-feedback1.md@ and the+-- Decision Log entry of 2026-05-03 in+-- @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@.+toggleFeedback1Canonical :: Text+toggleFeedback1Canonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> Off_Pol_Off",+      "    Off_Pol_Off --> On_Pol_On : TgFlip / TgFlipped",+      "    Off_Pol_On --> On_Pol_Off : TgFlip / TgFlipped",+      "    On_Pol_Off --> Off_Pol_On : TgFlip / TgFlipped",+      "    On_Pol_On --> Off_Pol_Off : TgFlip / TgFlipped",+      "    Off_Pol_Off --> [*]",+      "    Off_Pol_On --> [*]",+      "    On_Pol_Off --> [*]",+      "    On_Pol_On --> [*]"+    ]++-- * Synthetic 3-deep compose fixture (EP-35 M1 / M2) -------------------++-- | A minimal shared command/event type for the three toy aggregates.+-- Single nullary constructor so each toy's edge needs only a trivial+-- guard ('PInCtor' on 'inCtorTick') and a trivial output ('pack' over+-- the same constructor on both sides). The empty payload also makes+-- the 'InCtor' / 'WireCtor' values fully recoverable without any TH.+data Tick = Tick+  deriving (Eq, Show)++inCtorTick :: InCtor Tick '[]+inCtorTick =+  InCtor+    { icName = "Tick",+      icMatch = \Tick -> Just RNil,+      icBuild = \RNil -> Tick+    }++wireTick :: WireCtor Tick ()+wireTick =+  WireCtor+    { wcName = "Tick",+      wcMatch = \Tick -> Just (),+      wcBuild = \() -> Tick+    }++data T1 = T1A | T1B+  deriving (Eq, Show, Enum, Bounded)++data T2 = T2A | T2B+  deriving (Eq, Show, Enum, Bounded)++data T3 = T3A | T3B+  deriving (Eq, Show, Enum, Bounded)++-- | Each toy advances on a single 'Tick' command from the @A@ vertex+-- to the @B@ vertex; the @B@ vertex is final and has no outgoing+-- edges. All three toys share the @Tick@ alphabet so the+-- right-associative 'compose' chain type-checks without lifters.+toy1 :: SymTransducer (HsPred '[] Tick) '[] T1 Tick Tick+toy1 =+  mkToy+    T1A+    T1B+    (\case T1A -> True; T1B -> False)+    (\case T1B -> True; T1A -> False)++toy2 :: SymTransducer (HsPred '[] Tick) '[] T2 Tick Tick+toy2 =+  mkToy+    T2A+    T2B+    (\case T2A -> True; T2B -> False)+    (\case T2B -> True; T2A -> False)++toy3 :: SymTransducer (HsPred '[] Tick) '[] T3 Tick Tick+toy3 =+  mkToy+    T3A+    T3B+    (\case T3A -> True; T3B -> False)+    (\case T3B -> True; T3A -> False)++-- | Shared toy-aggregate factory: one Tick edge from the source+-- vertex to the target vertex; target is final. Parameterised on the+-- vertex predicates so each call site uses its own concrete vertex+-- type.+mkToy ::+  s ->+  s ->+  (s -> Bool) ->+  (s -> Bool) ->+  SymTransducer (HsPred '[] Tick) '[] s Tick Tick+mkToy src tgt isSrc isFinalAt =+  SymTransducer+    { edgesOut = \s ->+        if isSrc s+          then+            [ Edge+                { guard = PInCtor inCtorTick,+                  update = UKeep,+                  output = [pack inCtorTick wireTick OFNil],+                  target = tgt+                }+            ]+          else [],+      initial = src,+      initialRegs = RNil,+      isFinal = isFinalAt+    }++-- | The right-associative 3-deep compose @toy1 \`compose\` (toy2+-- \`compose\` toy3)@. Vertex type+-- @'Composite' T1 ('Composite' T2 T3)@; 2 × 2 × 2 = 8 composite+-- vertices walked by the renderer's @[minBound .. maxBound]@.+toy3deep ::+  SymTransducer+    (HsPred '[] Tick)+    '[]+    (Composite T1 (Composite T2 T3))+    Tick+    Tick+toy3deep = toy1 `compose` (toy2 `compose` toy3)++-- | Canonical Mermaid block for @toMermaidCompose3 toy3deep@.+-- Generated by running the renderer at the REPL and pasted verbatim;+-- regenerate via the recipe in+-- @docs/plans/35-mermaid-renderer-for-right-associative-3-deep-compose-composites.md@'s+-- Concrete Steps section if 'toMermaidCompose3' or 'compose'+-- semantics ever change.+toy3deepFlatCanonical :: Text+toy3deepFlatCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> T1A_T2A_T3A",+      "    T1A_T2A_T3A --> T1B_T2B_T3B : Tick / Tick",+      "    T1B_T2B_T3B --> [*]"+    ]++-- | Canonical Mermaid block for @toMermaidCompose3Nested toy3deep@.+-- Same fixture as the flat variant; differs in the per-outer+-- @state … { … }@ wrapping. Outer @T1@ vertices each list four+-- @T1?_T2?_T3?@ inner identifiers (the @T2@ × @T3@ cross-product+-- enumerated within @Composite T2 T3@'s 'Bounded' / 'Enum'+-- instances). Edges and finals remain at the top level using flat+-- identifiers.+toy3deepNestedCanonical :: Text+toy3deepNestedCanonical =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> T1A_T2A_T3A",+      "    state T1A {",+      "        T1A_T2A_T3A",+      "        T1A_T2A_T3B",+      "        T1A_T2B_T3A",+      "        T1A_T2B_T3B",+      "    }",+      "    state T1B {",+      "        T1B_T2A_T3A",+      "        T1B_T2A_T3B",+      "        T1B_T2B_T3A",+      "        T1B_T2B_T3B",+      "    }",+      "    T1A_T2A_T3A --> T1B_T2B_T3B : Tick / Tick",+      "    T1B_T2B_T3B --> [*]"+    ]++-- * Multi-event output fixture (EP-63 M2) -----------------------------++-- | A three-constructor event type so an edge can emit two and three+-- distinct events, exercising every 'MermaidOutputLayout'. The wire-ctor+-- names (@A@, @B@, @C@) are what the renderer prints.+data MEvt = MA | MB | MC+  deriving (Eq, Show)++-- | A single nullary command for the multi-event fixture.+data MCmd = MGo+  deriving (Eq, Show)++-- | Three vertices: @MS0@ emits three events, @MS1@ emits two, @MS2@+-- is final with no outgoing edge — enough to show all three output+-- layouts and the length-based default's @;@-vs-@<br/>@ switchover.+data MS = MS0 | MS1 | MS2+  deriving (Eq, Show, Enum, Bounded)++inCtorGo :: InCtor MCmd '[]+inCtorGo =+  InCtor+    { icName = "Go",+      icMatch = \MGo -> Just RNil,+      icBuild = \RNil -> MGo+    }++wireMA, wireMB, wireMC :: WireCtor MEvt ()+wireMA =+  WireCtor+    { wcName = "A",+      wcMatch = \case MA -> Just (); _ -> Nothing,+      wcBuild = \() -> MA+    }+wireMB =+  WireCtor+    { wcName = "B",+      wcMatch = \case MB -> Just (); _ -> Nothing,+      wcBuild = \() -> MB+    }+wireMC =+  WireCtor+    { wcName = "C",+      wcMatch = \case MC -> Just (); _ -> Nothing,+      wcBuild = \() -> MC+    }++-- | A tiny transducer whose @MS0@ edge emits three events and whose+-- @MS1@ edge emits two, so the three 'MermaidOutputLayout' goldens differ+-- observably. Both edges share the trivial guard @PInCtor inCtorGo@, so+-- the input half of every label reads @Go@.+multiEvt :: SymTransducer (HsPred '[] MCmd) '[] MS MCmd MEvt+multiEvt =+  SymTransducer+    { edgesOut = \case+        MS0 ->+          [ Edge+              { guard = PInCtor inCtorGo,+                update = UKeep,+                output =+                  [ pack inCtorGo wireMA OFNil,+                    pack inCtorGo wireMB OFNil,+                    pack inCtorGo wireMC OFNil+                  ],+                target = MS1+              }+          ]+        MS1 ->+          [ Edge+              { guard = PInCtor inCtorGo,+                update = UKeep,+                output =+                  [ pack inCtorGo wireMA OFNil,+                    pack inCtorGo wireMB OFNil+                  ],+                target = MS2+              }+          ]+        MS2 -> [],+      initial = MS0,+      initialRegs = RNil,+      isFinal = \case MS2 -> True; _ -> False+    }
+ test/Keiki/Render/PrettySpec.hs view
@@ -0,0 +1,132 @@+-- | Unit tests for "Keiki.Render.Pretty": the domain-readable+-- pretty-printer for 'HsPred' / 'Term' / 'Update'. Pure 'shouldBe'+-- assertions on exact rendered 'Text'.+module Keiki.Render.PrettySpec (spec) where++import Data.Proxy (Proxy (..))+import Data.Text qualified as T+import Keiki.Core+  ( Cmp (..),+    HsPred (..),+    InCtor (..),+    Index (..),+    NumOp (..),+    RegFile (..),+    Term (..),+    Update (..),+  )+import Keiki.Internal.Slots (IndexN (..))+import Keiki.Render.Pretty (prettyPred, prettyTerm, prettyUpdate)+import Test.Hspec++-- A two-slot register file schema: "balance" :: Int, "limit" :: Int.+type Regs = '[ '("balance", Int), '("limit", Int)]++-- An input type with one constructor "Deposit" carrying one field+-- "amount" :: Int.+data Cmd = Deposit Int+  deriving (Eq, Show)++type DepFields = '[ '("amount", Int)]++inCtorDeposit :: InCtor Cmd DepFields+inCtorDeposit =+  InCtor+    { icName = "Deposit",+      icMatch = \(Deposit n) -> Just (RCons (Proxy @"amount") n RNil),+      icBuild = \(RCons _ n RNil) -> Deposit n+    }++-- Index helpers (built by hand so we do not depend on OverloadedLabels+-- resolution here).+balanceIx :: Index Regs Int+balanceIx = ZIdx++limitIx :: Index Regs Int+limitIx = SIdx ZIdx++amountIx :: Index DepFields Int+amountIx = ZIdx++balanceN :: IndexN "balance" Regs Int+balanceN = IZ++spec :: Spec+spec = do+  describe "prettyTerm" $ do+    it "renders a register read by slot name" $+      prettyTerm (TReg balanceIx :: Term Regs Cmd '[] Int)+        `shouldBe` T.pack "balance"+    it "renders the second register by its slot name" $+      prettyTerm (TReg limitIx :: Term Regs Cmd '[] Int)+        `shouldBe` T.pack "limit"+    it "renders an input-field read as ctor.field" $+      prettyTerm (TInpCtorField inCtorDeposit amountIx :: Term Regs Cmd DepFields Int)+        `shouldBe` T.pack "Deposit.amount"+    it "renders a literal opaquely as <lit>" $+      prettyTerm (TLit (42 :: Int) :: Term Regs Cmd '[] Int)+        `shouldBe` T.pack "<lit>"+    it "renders TApp1 as <fn>(arg)" $+      prettyTerm (TApp1 (+ (1 :: Int)) (TReg balanceIx) :: Term Regs Cmd '[] Int)+        `shouldBe` T.pack "<fn>(balance)"+    it "renders TApp2 as <fn>(a, b)" $+      prettyTerm+        ( TApp2 ((+) :: Int -> Int -> Int) (TReg balanceIx) (TReg limitIx) ::+            Term Regs Cmd '[] Int+        )+        `shouldBe` T.pack "<fn>(balance, limit)"+    it "renders TArith add as (a + b)" $+      prettyTerm (TArith OpAdd (TReg balanceIx) (TReg limitIx) :: Term Regs Cmd '[] Int)+        `shouldBe` T.pack "(balance + limit)"+    it "renders TArith sub as (a - b)" $+      prettyTerm (TArith OpSub (TReg balanceIx) (TReg limitIx) :: Term Regs Cmd '[] Int)+        `shouldBe` T.pack "(balance - limit)"+    it "renders TArith mul as (a * b)" $+      prettyTerm (TArith OpMul (TReg balanceIx) (TReg limitIx) :: Term Regs Cmd '[] Int)+        `shouldBe` T.pack "(balance * limit)"++  describe "prettyPred" $ do+    it "renders PTop / PBot" $ do+      prettyPred (PTop :: HsPred Regs Cmd) `shouldBe` T.pack "true"+      prettyPred (PBot :: HsPred Regs Cmd) `shouldBe` T.pack "false"+    it "renders PInCtor as the constructor name" $+      prettyPred (PInCtor inCtorDeposit :: HsPred Regs Cmd)+        `shouldBe` T.pack "Deposit"+    it "renders PEq structurally with <lit> on the literal side" $+      prettyPred (PEq (TReg balanceIx) (TLit (0 :: Int)) :: HsPred Regs Cmd)+        `shouldBe` T.pack "balance == <lit>"+    it "renders each PCmp direction" $ do+      prettyPred (PCmp CmpLt (TReg balanceIx) (TReg limitIx) :: HsPred Regs Cmd)+        `shouldBe` T.pack "balance < limit"+      prettyPred (PCmp CmpLe (TReg balanceIx) (TReg limitIx) :: HsPred Regs Cmd)+        `shouldBe` T.pack "balance <= limit"+      prettyPred (PCmp CmpGt (TReg balanceIx) (TReg limitIx) :: HsPred Regs Cmd)+        `shouldBe` T.pack "balance > limit"+      prettyPred (PCmp CmpGe (TReg balanceIx) (TReg limitIx) :: HsPred Regs Cmd)+        `shouldBe` T.pack "balance >= limit"+    it "renders boolean structure with && || !" $+      prettyPred+        ( PAnd+            (PInCtor inCtorDeposit)+            ( POr+                (PCmp CmpGe (TReg balanceIx) (TLit (0 :: Int)))+                (PNot (PEq (TReg limitIx) (TLit (0 :: Int))))+            ) ::+            HsPred Regs Cmd+        )+        `shouldBe` T.pack "(Deposit && (balance >= <lit> || !(limit == <lit>)))"++  describe "prettyUpdate" $ do+    it "renders UKeep" $+      prettyUpdate (UKeep :: Update Regs '[] Cmd) `shouldBe` T.pack "(keep)"+    it "renders USet as slot := term" $+      prettyUpdate (USet balanceN (TLit (0 :: Int)) :: Update Regs '["balance"] Cmd)+        `shouldBe` T.pack "balance := <lit>"+    it "renders UCombine comma-separated" $+      prettyUpdate+        ( UCombine+            (USet balanceN (TReg limitIx))+            (USet balanceN (TLit (1 :: Int))) ::+            Update Regs '["balance", "balance"] Cmd+        )+        `shouldBe` T.pack "balance := limit, balance := <lit>"
+ test/Keiki/Render/ValidateSpec.hs view
@@ -0,0 +1,139 @@+-- | Unit tests for "Keiki.Render.Validate" (EP-66). Pure, hspec-only:+-- each crafted diagram produces exactly the listed warning value, and a+-- well-formed diagram produces the empty list.+--+-- See @docs/plans/66-pure-mermaid-diagram-and-atlas-validation-helpers.md@.+module Keiki.Render.ValidateSpec (spec) where++import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Render.Validate+  ( MermaidValidationOptions (..),+    MermaidValidationWarning (..),+    defaultMermaidValidationOptions,+    validateMermaidAtlas,+    validateMermaidDiagram,+  )+import Test.Hspec++spec :: Spec+spec = do+  describe "validateMermaidDiagram" $ do+    it "passes a well-formed diagram" $+      validateMermaidDiagram defaultMermaidValidationOptions goodDiagram+        `shouldBe` []++    it "flags a missing stateDiagram-v2 header" $+      validateMermaidDiagram defaultMermaidValidationOptions noHeader+        `shouldBe` [MissingStateDiagramHeader]++    it "flags an empty diagram (header with nothing under it)" $+      validateMermaidDiagram defaultMermaidValidationOptions onlyHeader+        `shouldBe` [EmptyDiagram]++    it "flags an over-length label with line, length and text" $+      validateMermaidDiagram tinyBudget goodDiagram+        `shouldBe` [LabelTooLong {warnLine = 3, warnLength = 13, warnLabel = T.pack "A / LongEvent"}]++    it "flags a suspicious unescaped character in a label" $+      validateMermaidDiagram defaultMermaidValidationOptions pipeLabel+        `shouldBe` [SuspiciousUnescapedChar {warnLine = 3, warnChar = '|', warnLabel = T.pack "Cmd / a|b"}]++    it "does not flag the deliberate <br/> tag keiki emits" $+      validateMermaidDiagram defaultMermaidValidationOptions brDiagram+        `shouldBe` []++    it "flags a duplicate declared state id but not endpoint recurrence" $+      validateMermaidDiagram defaultMermaidValidationOptions dupDecls+        `shouldBe` [DuplicateStateId {warnStateId = T.pack "S1"}]++  describe "validateMermaidAtlas" $+    it "aggregates warnings across fenced mermaid blocks in block order" $+      validateMermaidAtlas defaultMermaidValidationOptions atlas+        `shouldBe` [MissingStateDiagramHeader]++-- | A well-formed two-state diagram; its line-3 label is 13 characters.+goodDiagram :: Text+goodDiagram =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> S1",+      "    S1 --> S2 : A / LongEvent",+      "    S2 --> [*]"+    ]++-- | 'defaultMermaidValidationOptions' with a 5-character label budget.+tinyBudget :: MermaidValidationOptions+tinyBudget = defaultMermaidValidationOptions {maxLabelLength = Just 5}++-- | No @stateDiagram-v2@ header line.+noHeader :: Text+noHeader =+  T.intercalate+    (T.pack "\n")+    [ "    [*] --> S1",+      "    S1 --> [*]"+    ]++-- | A header with no body.+onlyHeader :: Text+onlyHeader = T.pack "stateDiagram-v2"++-- | A label carrying a single denylisted character (the pipe @|@).+pipeLabel :: Text+pipeLabel =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> S1",+      "    S1 --> S2 : Cmd / a|b",+      "    S2 --> [*]"+    ]++-- | A label whose only angle brackets come from a deliberate @<br/>@ tag,+-- which the validator exempts.+brDiagram :: Text+brDiagram =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    [*] --> S1",+      "    S1 --> S2 : Cmd / A<br/>B",+      "    S2 --> [*]"+    ]++-- | The id @S1@ is declared twice (with conflicting display labels) and+-- also recurs as a transition endpoint; only the declaration clash is a+-- duplicate.+dupDecls :: Text+dupDecls =+  T.intercalate+    (T.pack "\n")+    [ "stateDiagram-v2",+      "    state \"First\" as S1",+      "    state \"Second\" as S1",+      "    [*] --> S1",+      "    S1 --> [*]"+    ]++-- | A two-section atlas: one clean block, one block missing its header.+atlas :: Text+atlas =+  T.intercalate+    (T.pack "\n")+    [ "## Good",+      "",+      "```mermaid",+      "stateDiagram-v2",+      "    [*] --> S1",+      "    S1 --> [*]",+      "```",+      "",+      "## Bad",+      "",+      "```mermaid",+      "    [*] --> S1",+      "    S1 --> [*]",+      "```"+    ]
+ test/Keiki/ShapeSpec.hs view
@@ -0,0 +1,76 @@+-- | EP-36 M1: golden-value tests for 'Keiki.Shape'.+--+-- The expected strings are pinned for GHC 9.12.* (the current sole entry+-- in @tested-with@). If a future GHC moves @Int@ out of @GHC.Types@ or+-- renames @GHC.Internal.Maybe@, these tests catch the drift; EP-36 §8+-- documents the procedure (audit, mitigate via 'CanonicalTypeName'+-- overrides, decide whether to ship a migration). See EP-36 §3 R4 (cross-+-- version stability) and §5 P5 (the hash uses only stable accessors).+module Keiki.ShapeSpec (spec) where++import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Text qualified as T+import Data.Time.Clock (UTCTime)+import GHC.TypeLits (Symbol)+import Keiki.Shape+  ( regFileShapeCanonical,+    regFileShapeHash,+    renderStableTypeRep,+    sha256Hex,+  )+import Test.Hspec (Spec, describe, it, shouldBe)+import Type.Reflection (someTypeRep)++spec :: Spec+spec = do+  describe "renderStableTypeRep" $ do+    it "renders Int as GHC.Types.Int (no module path drift on 9.12.*)" $+      renderStableTypeRep (someTypeRep (Proxy @Int))+        `shouldBe` T.pack "GHC.Types.Int"++    it "renders Maybe Int as a parenthesised application" $+      renderStableTypeRep (someTypeRep (Proxy @(Maybe Int)))+        `shouldBe` T.pack "GHC.Internal.Maybe.Maybe(GHC.Types.Int)"++    it "renders UTCTime as its time-library module path" $+      renderStableTypeRep (someTypeRep (Proxy @UTCTime))+        `shouldBe` T.pack "Data.Time.Clock.Internal.UTCTime.UTCTime"++  describe "regFileShapeCanonical" $ do+    it "anchors the empty slot list at \"regfile:0\"" $+      regFileShapeCanonical (Proxy @('[] :: [(Symbol, Type)]))+        `shouldBe` T.pack "regfile:0"++    it "concatenates one slot in the documented R3 form" $+      regFileShapeCanonical (Proxy @('[ '("retryCount", Int)] :: [(Symbol, Type)]))+        `shouldBe` T.pack "retryCount:GHC.Types.Int;regfile:0"++  describe "regFileShapeHash" $ do+    it "produces the pinned SHA-256 of \"regfile:0\" for the empty list" $+      regFileShapeHash (Proxy @('[] :: [(Symbol, Type)]))+        `shouldBe` T.pack "0b262a9e301796f7a5b36bb6ea874e9ffccf7d1b4aff78a8d4b5436bd23914a6"++    it "produces the pinned hash for a one-slot list (retryCount :: Int)" $+      regFileShapeHash (Proxy @('[ '("retryCount", Int)] :: [(Symbol, Type)]))+        `shouldBe` T.pack "e2c8839d9ae8e89baebbc1adf6dfd5a35608712d9bf994c7cef4ea774e739700"++    it "differs when slot order is reversed (P10: slot order is identity)" $+      regFileShapeHash+        (Proxy @('[ '("retryCount", Int), '("cooldownUntil", UTCTime)] :: [(Symbol, Type)]))+        `shouldBe` T.pack "944d775449408b12b78b2a41770af207bae37d0a833c046310eb6ff3902ea44f"++    it "matches its sha256Hex-of-canonical definition" $ do+      let p = Proxy @('[ '("retryCount", Int), '("cooldownUntil", UTCTime)] :: [(Symbol, Type)])+      regFileShapeHash p `shouldBe` sha256Hex (regFileShapeCanonical p)++  describe "sha256Hex" $ do+    -- "" → e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+    -- "abc" → ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad+    it "matches the empty-string SHA-256 vector" $+      sha256Hex (T.pack "")+        `shouldBe` T.pack "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"++    it "matches the \"abc\" SHA-256 vector" $+      sha256Hex (T.pack "abc")+        `shouldBe` T.pack "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
+ test/Keiki/StepEitherSpec.hs view
@@ -0,0 +1,87 @@+module Keiki.StepEitherSpec (spec) where++import Keiki.Core+import Test.Hspec++-- Vertices: 0 has two always-true edges (ambiguous); 1 has one+-- always-false edge (no match); 2 has no edges; 3 has one always-true+-- edge (the normal accepting case).+data V = V0 | V1 | V2 | V3 | VEnd+  deriving stock (Eq, Show)++-- A no-op output term is awkward to build generically; instead each+-- edge below uses an empty output list ([]), so a successful step emits+-- no events. That keeps the fixture free of WireCtor/InCtor plumbing+-- while still exercising the Right path.+fixture :: SymTransducer (HsPred '[] Bool) '[] V Bool String+fixture =+  SymTransducer+    { edgesOut = \case+        V0 ->+          [ Edge {guard = PTop, update = UKeep, output = [], target = VEnd},+            Edge {guard = PTop, update = UKeep, output = [], target = V3}+          ]+        V1 -> [Edge {guard = PBot, update = UKeep, output = [], target = VEnd}]+        V2 -> []+        V3 -> [Edge {guard = PTop, update = UKeep, output = [], target = VEnd}]+        VEnd -> [],+      initial = V0,+      initialRegs = RNil,+      isFinal = (== VEnd)+    }++-- NOTE: 'RegFile' has no 'Eq'/'Show' instance (verified 2026-06-06), so we+-- cannot 'shouldBe' a whole 'Either (StepFailure V) (V, RegFile '[], [String])'.+-- The failure ('Left') values carry no register data and ARE 'Eq'/'Show', so+-- we pattern-match the result and compare only the inspectable parts. The+-- register file for the empty slot list @'[]@ has exactly one inhabitant+-- ('RNil'), so register equality on the success path is trivially preserved.+spec :: Spec+spec = do+  describe "stepEither" $ do+    it "reports NoOutgoingEdges for a vertex with no edges" $+      case stepEither fixture (V2, RNil) True of+        Left f -> f `shouldBe` NoOutgoingEdges V2+        Right _ -> expectationFailure "expected Left NoOutgoingEdges"++    it "reports NoMatchingEdge with one rejected summary per edge" $+      case stepEither fixture (V1, RNil) True of+        Left f ->+          f+            `shouldBe` NoMatchingEdge+              V1+              [ RejectedEdgeSummary+                  { rejectedEdge = EdgeRef {edgeSource = V1, edgeIndex = 0},+                    rejectedTarget = VEnd,+                    rejectedGuard = False+                  }+              ]+        Right _ -> expectationFailure "expected Left NoMatchingEdge"++    it "reports AmbiguousEdges listing every matched edge" $+      case stepEither fixture (V0, RNil) True of+        Left f ->+          f+            `shouldBe` AmbiguousEdges+              V0+              [ MatchedEdgeSummary+                  { matchedEdge = EdgeRef {edgeSource = V0, edgeIndex = 0},+                    matchedTarget = VEnd+                  },+                MatchedEdgeSummary+                  { matchedEdge = EdgeRef {edgeSource = V0, edgeIndex = 1},+                    matchedTarget = V3+                  }+              ]+        Right _ -> expectationFailure "expected Left AmbiguousEdges"++    it "returns Right with the same target/regs/events as a normal edge" $+      case stepEither fixture (V3, RNil) True of+        Right (tgt, _regs, evs) -> (tgt, evs) `shouldBe` (VEnd, [])+        Left _ -> expectationFailure "expected Right"++    it "Right payload matches step exactly on the accepting edge" $+      case (step fixture (V3, RNil) True, stepEither fixture (V3, RNil) True) of+        (Just (s1, _r1, e1), Right (s2, _r2, e2)) -> (s1, e1) `shouldBe` (s2, e2)+        (Nothing, _) -> expectationFailure "step returned Nothing on the accepting edge"+        (_, Left f) -> expectationFailure ("stepEither returned Left: " <> show f)
+ test/Keiki/StrongSpec.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE BlockArguments #-}++-- | Acceptance tests for the 'Data.Profunctor.Strong.Strong' instance+-- on 'SomeSymTransducer' (EP-29 of MasterPlan 9, M2).+--+-- The Strong instance threads an unrelated value through a+-- transducer: @first'@ accepts a pair @(a, c)@ and emits @(b, c)@,+-- where @c@ is read straight from the input and paired with @t@'s+-- output. @second'@ is the symmetric @(c, a) -> (c, b)@.+--+-- Implemented from primitives because MP-8 (EP-24) declined a general+-- @parallel@ combinator. 'Keiki.Profunctor.firstSym' is the one-off+-- equivalent.+--+-- Fixture: 'Keiki.Fixtures.EmailDelivery' wrapped in+-- 'someSymTransducer' with a 'RequestId' threaded through. The tests+-- cover:+--+--   * Forward processing — @first'@ on a sample input+--     @(SendEmail, 42)@ produces @(EmailSent, 42)@.+--   * @second'@ symmetry on the swapped pair.+--   * Survival of 'Keiki.Symbolic.isSingleValuedSym'.+--   * Sentinel preservation: @first' Cat.id == Cat.id@.+module Keiki.StrongSpec (spec) where++import Control.Category qualified as Cat+import Data.Profunctor (Strong (..))+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+import Keiki.Core+import Keiki.Fixtures.EmailDelivery+import Keiki.Profunctor+import Keiki.Symbolic (isSingleValuedSym, withSymPred)+import Test.Hspec++-- * Fixtures ----------------------------------------------------------------++newtype RequestId = RequestId Int+  deriving stock (Eq, Show)++sampleAt :: UTCTime+sampleAt = UTCTime (fromGregorian 2026 5 9) (secondsToDiffTime 0)++sampleSendEmail :: EmailCmd+sampleSendEmail =+  SendEmail+    SendEmailData+      { recipient = "alice@example.com",+        subject = "hello",+        at = sampleAt+      }++sampleEmailEvent :: EmailEvent+sampleEmailEvent =+  EmailSent+    EmailSentData+      { recipient = "alice@example.com",+        subject = "hello",+        at = sampleAt+      }++someEmail :: SomeSymTransducer EmailCmd EmailEvent+someEmail = someSymTransducer emailDelivery++-- * Specs -------------------------------------------------------------------++spec :: Spec+spec = do+  describe "first'" $ do+    it "threads an unrelated RequestId through emailDelivery" $ do+      let routed :: SomeSymTransducer (EmailCmd, RequestId) (EmailEvent, RequestId)+          routed = first' someEmail+          requestId = RequestId 42+      case routed of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (sampleSendEmail, requestId)+            `shouldBe` [(sampleEmailEvent, requestId)]+        SomeSymIdentity ->+          expectationFailure+            "first' (someSymTransducer emailDelivery) unexpectedly returned \+            \the identity sentinel"++    it "preserves Cat.id on the sentinel: first' Cat.id == Cat.id" $ do+      let lifted :: SomeSymTransducer (Int, Bool) (Int, Bool)+          lifted = first' (Cat.id :: SomeSymTransducer Int Int)+      case lifted of+        SomeSymIdentity -> pure ()+        SomeSymTransducer _ ->+          expectationFailure "first' Cat.id should preserve the identity sentinel"++  describe "second'" $ do+    it "threads an unrelated RequestId through emailDelivery on the second slot" $ do+      let routed :: SomeSymTransducer (RequestId, EmailCmd) (RequestId, EmailEvent)+          routed = second' someEmail+          requestId = RequestId 99+      case routed of+        SomeSymTransducer t ->+          omega t (initial t) (initialRegs t) (requestId, sampleSendEmail)+            `shouldBe` [(requestId, sampleEmailEvent)]+        SomeSymIdentity ->+          expectationFailure+            "second' (someSymTransducer emailDelivery) unexpectedly returned \+            \the identity sentinel"++    it "preserves Cat.id on the sentinel: second' Cat.id == Cat.id" $ do+      let lifted :: SomeSymTransducer (Bool, Int) (Bool, Int)+          lifted = second' (Cat.id :: SomeSymTransducer Int Int)+      case lifted of+        SomeSymIdentity -> pure ()+        SomeSymTransducer _ ->+          expectationFailure "second' Cat.id should preserve the identity sentinel"++  describe "isSingleValuedSym survives first' / second'" $ do+    it "single-valuedness is preserved across first'" $+      case first' someEmail ::+             SomeSymTransducer (EmailCmd, RequestId) (EmailEvent, RequestId) of+        SomeSymTransducer t ->+          isSingleValuedSym (withSymPred t) `shouldBe` True+        SomeSymIdentity ->+          expectationFailure+            "first' on a non-identity wrapper returned the identity sentinel"++    it "single-valuedness is preserved across second'" $+      case second' someEmail ::+             SomeSymTransducer (RequestId, EmailCmd) (RequestId, EmailEvent) of+        SomeSymTransducer t ->+          isSingleValuedSym (withSymPred t) `shouldBe` True+        SomeSymIdentity ->+          expectationFailure+            "second' on a non-identity wrapper returned the identity sentinel"
+ test/Keiki/SymbolicSpec.hs view
@@ -0,0 +1,654 @@+module Keiki.SymbolicSpec (spec) where++import Data.Int (Int32, Int64)+import Data.Kind (Type)+import Data.Maybe (isJust, isNothing)+import Data.Proxy (Proxy (..))+import Data.SBV qualified as SBV+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Typeable (Typeable)+import Data.Word (Word16, Word32, Word64, Word8)+import Keiki.Symbolic+import Test.Hspec++-- | A two-constructor input symbol for the 'PInCtor' tests.+data TinyCmd = TinyFoo Int | TinyBar Int deriving (Eq, Show)++-- * Numeric-registry fixtures (EP-41 M1) ---------------------------------++-- | A single-slot register file whose value type is the money/count+-- carrier 'Word64'. Used to prove the EP-41 numeric instances make+-- fixed-width-integer slots solver-visible and witness-extractable.+type AmountRegs = '[ '("amount", Word64)]++-- | A one-constructor (empty-payload) input symbol for the numeric+-- fixture. The 'KnownInCtors' instance lets 'symSatExt' rebuild it.+data AmtCmd = AmtTick deriving (Eq, Show)++inCtorAmtTick :: InCtor AmtCmd '[]+inCtorAmtTick =+  InCtor+    { icName = "AmtTick",+      icMatch = \case AmtTick -> Just RNil,+      icBuild = \RNil -> AmtTick+    }++instance KnownInCtors AmtCmd where+  allInCtors = [SomeInCtor inCtorAmtTick]++-- | The 'amount' slot index, named once for reuse.+amountIdx :: Index AmountRegs Word64+amountIdx = ZIdx++-- | A two-edge transducer over a 'Word64' register. Both edges leave+-- the @False@ vertex; the second edge carries a constant 'Word64'+-- equality that is always false (@5 == 6@), so the pair is mutually+-- exclusive /iff/ the solver can see that @5 == 6@ is unsatisfiable+-- over 'Word64'. Before EP-41 added @Sym Word64@, that equality+-- translated to an opaque fresh 'SBool' and the verdict was @False@;+-- after EP-41 it is real SBV integer equality and the verdict is+-- @True@. Each guard reads the register at most once, so the verdict+-- does not depend on the deferred per-slot memoization.+amountFixture ::+  SymTransducer+    (HsPred AmountRegs AmtCmd)+    AmountRegs+    Bool+    AmtCmd+    ()+amountFixture =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = PEq (proj amountIdx) (lit (0 :: Word64)),+                update = UKeep,+                output = [],+                target = True+              },+            Edge+              { guard = PEq (lit (5 :: Word64)) (lit (6 :: Word64)),+                update = UKeep,+                output = [],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RCons (Proxy @"amount") 0 RNil,+      isFinal = (== True)+    }++-- | A two-edge transducer over the 'Word64' @amount@ register whose+-- /both/ guards read the register: @PEq #amount 0@ and @PEq #amount 1@.+-- Single-valuedness forms the conjunction @#amount == 0 ∧ #amount == 1@,+-- which is unsatisfiable only if the two reads of @#amount@ (one per+-- guard) share a single SBV variable. Before EP-42's per-slot+-- memoization the two reads were independent fresh variables, so the+-- conjunction stayed satisfiable and the verdict was @False@; after+-- EP-42 the shared variable makes it a real contradiction and the+-- verdict flips to @True@. Contrast 'amountFixture', whose second guard+-- is a /constant/ contradiction (@5 == 6@) that needs no memoization.+twoReadEdgeFixture ::+  SymTransducer+    (HsPred AmountRegs AmtCmd)+    AmountRegs+    Bool+    AmtCmd+    ()+twoReadEdgeFixture =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = PEq (proj amountIdx) (lit (0 :: Word64)),+                update = UKeep,+                output = [],+                target = True+              },+            Edge+              { guard = PEq (proj amountIdx) (lit (1 :: Word64)),+                update = UKeep,+                output = [],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RCons (Proxy @"amount") 0 RNil,+      isFinal = (== True)+    }++-- * Structural-arithmetic fixtures (EP-43) -------------------------------++-- | A four-slot 'Int' register file for structural-arithmetic proofs:+-- @#a@/@#b@ feed a sum, @#score@/@#req@ feed a multiply-cap.+type ArithRegs = '[ '("a", Int), '("b", Int), '("score", Int), '("req", Int)]++aIdx, bIdx, scoreIdx, reqIdx :: Index ArithRegs Int+aIdx = #a+bIdx = #b+scoreIdx = #score+reqIdx = #req++-- | A one-constructor (empty-payload) input for the arithmetic+-- fixtures. The 'KnownInCtors' instance lets 'symSatExt' rebuild it.+data ArithCmd = ArithTick deriving (Eq, Show)++inCtorArithTick :: InCtor ArithCmd '[]+inCtorArithTick =+  InCtor+    { icName = "ArithTick",+      icMatch = \case ArithTick -> Just RNil,+      icBuild = \RNil -> ArithTick+    }++instance KnownInCtors ArithCmd where+  allInCtors = [SomeInCtor inCtorArithTick]++-- | A full 'ArithRegs' register file from four 'Int' values, in slot+-- order @a, b, score, req@. Used by the @evalPred@/@evalTerm@ agreement+-- proof.+arithRegs :: Int -> Int -> Int -> Int -> RegFile ArithRegs+arithRegs a b s r =+  RCons+    (Proxy @"a")+    a+    ( RCons+        (Proxy @"b")+        b+        ( RCons+            (Proxy @"score")+            s+            (RCons (Proxy @"req") r RNil)+        )+    )++inCtorTinyFoo :: InCtor TinyCmd '[ '("a", Int)]+inCtorTinyFoo =+  InCtor+    { icName = "TinyFoo",+      icMatch = \case+        TinyFoo a -> Just (RCons (Proxy @"a") a RNil)+        _ -> Nothing,+      icBuild = \(RCons _ a RNil) -> TinyFoo a+    }++inCtorTinyBar :: InCtor TinyCmd '[ '("b", Int)]+inCtorTinyBar =+  InCtor+    { icName = "TinyBar",+      icMatch = \case+        TinyBar b -> Just (RCons (Proxy @"b") b RNil)+        _ -> Nothing,+      icBuild = \(RCons _ b RNil) -> TinyBar b+    }++-- | Run an 'HsPred' through the SBV translator and ask the solver+-- whether the conjunction of the predicate translation is+-- satisfiable. Returns 'True' if SBV reports a model; 'False' if it+-- reports unsat or unknown.+satP :: forall rs ci. HsPred rs ci -> IO Bool+satP p = do+  res <- SBV.sat $ do+    env <- mkSymEnv+    translatePred env p+  pure (SBV.modelExists res)++-- | Run an 'HsPred' as a /claim/ and ask the solver whether its+-- negation is unsatisfiable, i.e. the claim is a tautology.+proveP :: forall rs ci. HsPred rs ci -> IO Bool+proveP p = do+  res <- SBV.prove $ do+    env <- mkSymEnv+    translatePred env p+  pure (not (SBV.modelExists res))++spec :: Spec+spec = do+  describe "discoverSym (curated registry)" $ do+    it "discovers Sym Bool" $ symKnown (Proxy @Bool) `shouldBe` True+    it "discovers Sym Int" $ symKnown (Proxy @Int) `shouldBe` True+    it "discovers Sym Integer" $ symKnown (Proxy @Integer) `shouldBe` True+    it "discovers Sym Text" $ symKnown (Proxy @Text) `shouldBe` True+    it "discovers Sym UTCTime" $ symKnown (Proxy @UTCTime) `shouldBe` True+    -- EP-41: fixed-width integers (money + counts).+    it "discovers Sym Word64" $ symKnown (Proxy @Word64) `shouldBe` True+    it "discovers Sym Word32" $ symKnown (Proxy @Word32) `shouldBe` True+    it "discovers Sym Word16" $ symKnown (Proxy @Word16) `shouldBe` True+    it "discovers Sym Word8" $ symKnown (Proxy @Word8) `shouldBe` True+    it "discovers Sym Int64" $ symKnown (Proxy @Int64) `shouldBe` True+    it "discovers Sym Int32" $ symKnown (Proxy @Int32) `shouldBe` True+    it "rejects unknown types" $ symKnown (Proxy @()) `shouldBe` False++  describe "numeric Sym registry (EP-41 M1)" $ do+    it "Word64 equality is solver-visible: isBot (PEq lit5 lit6) is True" $+      -- Before M1 this was False (opaque 'neq' fallback); after M1 it is+      -- a real SBV integer contradiction.+      isBot (SymPred (PEq (TLit (5 :: Word64)) (TLit 6)) :: SymPred '[] ())+        `shouldBe` True+    it "Word64 equality stays sat when consistent: isBot (PEq lit5 lit5) is False" $+      isBot (SymPred (PEq (TLit (5 :: Word64)) (TLit 5)) :: SymPred '[] ())+        `shouldBe` False+    it "Word32 equality is solver-visible: isBot (PEq lit10 lit11) is True" $+      isBot (SymPred (PEq (TLit (10 :: Word32)) (TLit 11)) :: SymPred '[] ())+        `shouldBe` True+    it "isSingleValuedSym sees a now-visible constant Word64 contradiction" $+      -- The amountFixture's second edge guard is the always-false+      -- Word64 equality 5 == 6, which only becomes solver-visible with+      -- the EP-41 'Sym Word64' instance. Verdict flips False -> True.+      isSingleValuedSym (withSymPred amountFixture) `shouldBe` True+    it "symSatExt round-trips a Word64 slot (amount == 7)" $ do+      -- Single read of #amount (memoization-safe); PInCtor pins the+      -- input constructor so witness reconstruction succeeds.+      let p =+            PAnd+              (PInCtor inCtorAmtTick)+              (PEq (proj amountIdx) (lit (7 :: Word64))) ::+              HsPred AmountRegs AmtCmd+      case symSatExt p of+        Nothing -> expectationFailure "Word64 equality reported unsat"+        Just (regs, cmd) -> do+          (regs ! amountIdx) `shouldBe` (7 :: Word64)+          cmd `shouldBe` AmtTick+          evalPred p regs cmd `shouldBe` True++  describe "ordering predicate PCmp (EP-41 M2)" $ do+    it "constant contradiction 5 >= 10 over Word64 is symIsBot" $+      -- Before M2 this guard could only be written via TApp (opaque)+      -- and would be symIsBot == False.+      symIsBot+        ( PAnd (PCmp CmpGe (TLit (5 :: Word64)) (TLit 10)) PTop ::+            HsPred '[] ()+        )+        `shouldBe` True+    it "satisfiable constant 10 >= 5 over Word64 is not symIsBot" $+      symIsBot (PCmp CmpGe (TLit (10 :: Word64)) (TLit 5) :: HsPred '[] ())+        `shouldBe` False+    it "symSatExt witness respects amount >= 1000" $ do+      let p =+            PAnd+              (PInCtor inCtorAmtTick)+              (PCmp CmpGe (proj amountIdx) (lit (1000 :: Word64))) ::+              HsPred AmountRegs AmtCmd+      case symSatExt p of+        Nothing -> expectationFailure "amount >= 1000 reported unsat"+        Just (regs, cmd) -> do+          (regs ! amountIdx >= 1000) `shouldBe` True+          evalPred p regs cmd `shouldBe` True+    it "evalPred agrees with Haskell comparison for every Cmp direction" $ do+      let vals = [3, 5, 5, 7] :: [Int]+          chk op f =+            and+              [ evalPred+                  (PCmp op (TLit x) (TLit y) :: HsPred '[] ())+                  RNil+                  ()+                  == f x y+              | x <- vals,+                y <- vals+              ]+      chk CmpLt (<) `shouldBe` True+      chk CmpLe (<=) `shouldBe` True+      chk CmpGt (>) `shouldBe` True+      chk CmpGe (>=) `shouldBe` True++  describe "memoization (EP-42)" $ do+    -- All four assertions exercise repeated reads of the same register+    -- #amount. Before EP-42 each read minted a fresh SBV variable, so+    -- the solver believed two reads of #amount could disagree; after+    -- EP-42 they share one variable. Recorded before-values (M0 repl,+    -- mirrored on #x): F1 symIsBot (x /= x) = False, symSatExt = Just;+    -- F3 the two-edge fixture verdict = False. See the plan's+    -- Surprises & Discoveries.+    let pNeq =+          PNot (PEq (proj amountIdx) (proj amountIdx)) ::+            HsPred AmountRegs AmtCmd+        pEq =+          PEq (proj amountIdx) (proj amountIdx) ::+            HsPred AmountRegs AmtCmd++    it "x /= x is empty: symIsBot (PNot (PEq #amount #amount)) is True" $+      symIsBot pNeq `shouldBe` True++    it "x /= x is unsat via symSatExt: symSatExt (PNot (PEq #amount #amount)) is Nothing" $+      isJust (symSatExt pNeq) `shouldBe` False++    it "x == x stays satisfiable: symIsBot (PEq #amount #amount) is False (sanity)" $+      symIsBot pEq `shouldBe` False++    it "two edges PEq #amount 0 / PEq #amount 1 are single-valued" $+      -- The single-valuedness conjunction is #amount == 0 ∧ #amount == 1,+      -- a contradiction only when the two reads share one variable.+      isSingleValuedSym (withSymPred twoReadEdgeFixture) `shouldBe` True++    it "a repeated-read contradiction has no witness: symSatExt (#amount==0 ∧ #amount==1) is Nothing" $ do+      -- Same conjunction as the single-valuedness gate, surfaced through+      -- symSatExt. Before EP-42 the independent reads let the solver+      -- satisfy #amount==0 and #amount==1 separately, so symSatExt+      -- returned a Just whose by-name witness failed models; after EP-42+      -- the shared variable makes it a true contradiction (Nothing).+      let pContra =+            PAnd+              (PInCtor inCtorAmtTick)+              ( PAnd+                  (PEq (proj amountIdx) (lit (0 :: Word64)))+                  (PEq (proj amountIdx) (lit (1 :: Word64)))+              ) ::+              HsPred AmountRegs AmtCmd+      isNothing (symSatExt pContra) `shouldBe` True++    it "symSatExt witness over a repeated read satisfies models" $ do+      -- Positive round-trip: a satisfiable repeated-read predicate. The+      -- by-name witness now coincides with the single shared variable,+      -- so it satisfies models. (PInCtor pins the constructor so witness+      -- reconstruction succeeds.)+      let p =+            PAnd+              (PInCtor inCtorAmtTick)+              (PEq (proj amountIdx) (proj amountIdx)) ::+              HsPred AmountRegs AmtCmd+      case symSatExt p of+        Nothing -> expectationFailure "repeated-read predicate reported unsat"+        Just (regs, cmd) -> models (SymPred p) (regs, cmd) `shouldBe` True++  describe "structural arithmetic (EP-43)" $ do+    -- Before EP-43 a computed operand could only be written through an+    -- opaque TApp, so the solver saw a fresh unconstrained variable and+    -- a constant arithmetic contradiction was reported satisfiable.++    it "constant 2 + 3 > 10 is symIsBot (empty)" $+      symIsBot+        ( PCmp CmpGt (tadd (lit (2 :: Int)) (lit 3)) (lit 10) ::+            HsPred '[] ()+        )+        `shouldBe` True++    it "constant 2 + 3 >= 5 is not symIsBot (satisfiable)" $+      symIsBot+        ( PCmp CmpGe (tadd (lit (2 :: Int)) (lit 3)) (lit 5) ::+            HsPred '[] ()+        )+        `shouldBe` False++    it "constant 10 - 3 == 8 is symIsBot (contradiction)" $+      symIsBot+        ( PEq (tsub (lit (10 :: Int)) (lit 3)) (lit 8) ::+            HsPred '[] ()+        )+        `shouldBe` True++    it "constant 4 * 3 == 12 is not symIsBot (consistent)" $+      symIsBot+        ( PEq (tmul (lit (4 :: Int)) (lit 3)) (lit 12) ::+            HsPred '[] ()+        )+        `shouldBe` False++    it "symSatExt witness respects #a + #b >= 10" $ do+      -- #a and #b are distinct registers, so this needs no memoization;+      -- the witness sum must actually clear the bound.+      let p =+            PAnd+              (PInCtor inCtorArithTick)+              (PCmp CmpGe (tadd (proj aIdx) (proj bIdx)) (lit 10)) ::+              HsPred ArithRegs ArithCmd+      case symSatExt p of+        Nothing -> expectationFailure "#a + #b >= 10 reported unsat"+        Just (regs, cmd) -> do+          ((regs ! aIdx) + (regs ! bIdx) >= 10) `shouldBe` True+          evalPred p regs cmd `shouldBe` True++    it "symSatExt witness respects #req <= #score * 1000" $ do+      let p =+            PAnd+              (PInCtor inCtorArithTick)+              (PCmp CmpLe (proj reqIdx) (tmul (proj scoreIdx) (lit 1000))) ::+              HsPred ArithRegs ArithCmd+      case symSatExt p of+        Nothing -> expectationFailure "#req <= #score * 1000 reported unsat"+        Just (regs, cmd) -> do+          ((regs ! reqIdx) <= (regs ! scoreIdx) * 1000) `shouldBe` True+          evalPred p regs cmd `shouldBe` True++    it "evalTerm/evalPred over tadd/tsub/tmul matches Haskell arithmetic" $ do+      let vals = [-2, 0, 3, 7] :: [Int]+          chk f mk =+            and+              [ evalPred+                  ( PEq (mk (proj aIdx) (proj bIdx)) (lit (f a b)) ::+                      HsPred ArithRegs ArithCmd+                  )+                  (arithRegs a b 0 0)+                  ArithTick+              | a <- vals,+                b <- vals+              ]+      chk (+) tadd `shouldBe` True+      chk (-) tsub `shouldBe` True+      chk (*) tmul `shouldBe` True++  describe "translatePred (boolean skeleton)" $ do+    it "PTop is a tautology" $ do+      proveP (PTop :: HsPred '[] ()) `shouldReturn` True+    it "PBot is unsatisfiable" $ do+      satP (PBot :: HsPred '[] ()) `shouldReturn` False+    it "PAnd PTop PTop is a tautology" $ do+      proveP (PAnd PTop PTop :: HsPred '[] ()) `shouldReturn` True+    it "POr PBot PBot is unsatisfiable" $ do+      satP (POr PBot PBot :: HsPred '[] ()) `shouldReturn` False+    it "PNot PTop is unsatisfiable" $ do+      satP (PNot PTop :: HsPred '[] ()) `shouldReturn` False++  describe "translatePred over PEq (SBV-supported types)" $ do+    it "PEq (TLit 5) (TLit 5) is a tautology" $ do+      proveP (PEq (TLit (5 :: Int)) (TLit 5) :: HsPred '[] ())+        `shouldReturn` True+    it "PEq (TLit 5) (TLit 6) is unsatisfiable" $ do+      satP (PEq (TLit (5 :: Int)) (TLit 6) :: HsPred '[] ())+        `shouldReturn` False++  describe "translatePred over PInCtor (constructor mutual exclusion)" $ do+    it "PInCtor inCtorTinyFoo is satisfiable in isolation" $ do+      satP (PInCtor inCtorTinyFoo :: HsPred '[] TinyCmd)+        `shouldReturn` True+    it "PInCtor inCtorTinyFoo AND PInCtor inCtorTinyBar is unsatisfiable" $ do+      satP+        ( PAnd+            (PInCtor inCtorTinyFoo)+            (PInCtor inCtorTinyBar) ::+            HsPred '[] TinyCmd+        )+        `shouldReturn` False+    it "PInCtor inCtorTinyFoo AND PInCtor inCtorTinyFoo is satisfiable" $ do+      satP+        ( PAnd+            (PInCtor inCtorTinyFoo)+            (PInCtor inCtorTinyFoo) ::+            HsPred '[] TinyCmd+        )+        `shouldReturn` True++  describe "SymPred BoolAlg structural ops (M4)" $ do+    it "top wraps PTop" $+      isPTop (unSymPred (top :: SymPred '[] ())) `shouldBe` True+    it "bot wraps PBot" $+      isPBot (unSymPred (bot :: SymPred '[] ())) `shouldBe` True+    it "conj p q wraps PAnd" $+      isPAnd (unSymPred (conj (top :: SymPred '[] ()) bot))+        `shouldBe` True+    it "disj p q wraps POr" $+      isPOr (unSymPred (disj (top :: SymPred '[] ()) bot))+        `shouldBe` True+    it "neg p wraps PNot" $+      isPNot (unSymPred (neg (top :: SymPred '[] ())))+        `shouldBe` True+    it "models delegates to evalPred (top is True)" $+      models (top :: SymPred '[] ()) (RNil, ())+        `shouldBe` True+    it "models delegates to evalPred (bot is False)" $+      models (bot :: SymPred '[] ()) (RNil, ())+        `shouldBe` False++  describe "SymPred BoolAlg solver-backed methods (M5)" $ do+    it "isBot bot is True" $+      isBot (bot :: SymPred '[] ()) `shouldBe` True+    it "isBot top is False" $+      isBot (top :: SymPred '[] ()) `shouldBe` False+    it "isBot (PEq lit5 lit6) is True (SBV unsat)" $+      isBot (SymPred (PEq (TLit (5 :: Int)) (TLit 6)) :: SymPred '[] ())+        `shouldBe` True+    it "isBot (PEq lit5 lit5) is False (SBV sat)" $+      isBot (SymPred (PEq (TLit (5 :: Int)) (TLit 5)) :: SymPred '[] ())+        `shouldBe` False+    it "isBot (PInCtor TinyFoo AND PInCtor TinyBar) is True (constructor mutex)" $+      isBot+        ( SymPred+            ( PAnd+                (PInCtor inCtorTinyFoo)+                (PInCtor inCtorTinyBar)+            ) ::+            SymPred '[] TinyCmd+        )+        `shouldBe` True+    it "sat top is Just _" $ do+      let result = sat (top :: SymPred '[] ()) :: Maybe (RegFile '[], ())+      isJust result `shouldBe` True+    it "sat bot is Nothing" $ do+      let result = sat (bot :: SymPred '[] ()) :: Maybe (RegFile '[], ())+      isJust result `shouldBe` False+    it "sat (PEq lit5 lit5) is Just _" $ do+      let result =+            sat+              ( SymPred (PEq (TLit (5 :: Int)) (TLit 5)) ::+                  SymPred '[] ()+              ) ::+              Maybe (RegFile '[], ())+      isJust result `shouldBe` True+    it "sat (PEq lit5 lit6) is Nothing" $ do+      let result =+            sat+              ( SymPred (PEq (TLit (5 :: Int)) (TLit 6)) ::+                  SymPred '[] ()+              ) ::+              Maybe (RegFile '[], ())+      isJust result `shouldBe` False++  describe "real BoolAlg.sat witness (EP-44)" $ do+    -- Before EP-44 'sat' on 'SymPred' returned a placeholder whose+    -- components crash when forced, so 'models' on the returned witness+    -- threw. These tests force the witness (via 'models', or by pattern-+    -- matching it), so each crashes before M1 and passes after.+    let pAmt =+          PEq (proj amountIdx) (lit (7 :: Word64)) ::+            HsPred AmountRegs AmtCmd+        pCtor =+          PInCtor inCtorAmtTick ::+            HsPred AmountRegs AmtCmd++    it "sat's witness is forceable and satisfies models (register guard)" $+      case sat (SymPred pAmt) of+        Nothing -> expectationFailure "expected pAmt satisfiable"+        Just w -> models (SymPred pAmt) w `shouldBe` True++    it "sat's witness reconstructs the command and satisfies models (PInCtor)" $+      case sat (SymPred pCtor) of+        Nothing -> expectationFailure "expected pCtor satisfiable"+        Just w -> models (SymPred pCtor) w `shouldBe` True++    it "sat on an unsatisfiable predicate is Nothing" $+      isNothing (sat (bot :: SymPred AmountRegs AmtCmd)) `shouldBe` True++    it "sat agrees with symSatExt on satisfiability" $ do+      isJust (sat (SymPred pAmt)) `shouldBe` isJust (symSatExt pAmt)+      isJust (sat (SymPred pCtor)) `shouldBe` isJust (symSatExt pCtor)++    it "sat over SymPred '[] () yields a real () witness (not a crashing placeholder)" $+      -- No 'PInCtor' pins the constructor; the EP-44 'seInputCtor' domain+      -- constraint + 'KnownInCtors ()' still reconstruct a real '()'.+      -- Forcing @c@ would have thrown the placeholder error before M1.+      case sat (top :: SymPred '[] ()) of+        Nothing -> expectationFailure "expected top satisfiable"+        Just (_, c) -> c `shouldBe` ()++  describe "isSingleValuedSym (M6)" $ do+    it "synthetic 2-edge with constructor-mutex guards is single-valued" $+      isSingleValuedSym synth2Mutex `shouldBe` True+    it "synthetic 2-edge with overlapping guards is not single-valued" $+      isSingleValuedSym synth2Overlap `shouldBe` False++-- | 'True' iff a 'Sym' instance is discoverable for @r@ at runtime+-- via the curated registry.+symKnown :: forall (r :: Type). (Typeable r) => Proxy r -> Bool+symKnown _ = case discoverSym :: Maybe (SymDict r) of+  Just _ -> True+  Nothing -> False++-- | Constructor-shape predicates for the M4 SymPred wrapper tests.+-- Each one is 'True' iff the supplied 'HsPred' has the named outermost+-- constructor.+isPTop, isPBot :: HsPred rs ci -> Bool+isPTop PTop = True; isPTop _ = False+isPBot PBot = True; isPBot _ = False++isPAnd, isPOr, isPNot :: HsPred rs ci -> Bool+isPAnd (PAnd _ _) = True; isPAnd _ = False+isPOr (POr _ _) = True; isPOr _ = False+isPNot (PNot _) = True; isPNot _ = False++-- * Synthetic transducers for isSingleValuedSym tests --------------------++-- | A two-edge transducer from @False@ whose guards are mutually+-- exclusive ('PInCtor TinyFoo' vs. 'PInCtor TinyBar'). The vertex+-- 'True' has no outgoing edges. The expected verdict is+-- 'isSingleValuedSym == True'.+synth2Mutex :: SymTransducer (SymPred '[] TinyCmd) '[] Bool TinyCmd ()+synth2Mutex =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = SymPred (PInCtor inCtorTinyFoo),+                update = UKeep,+                output = [],+                target = True+              },+            Edge+              { guard = SymPred (PInCtor inCtorTinyBar),+                update = UKeep,+                output = [],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = (== True)+    }++-- | A two-edge transducer with overlapping ('PTop') guards. The+-- expected verdict is 'isSingleValuedSym == False'.+synth2Overlap :: SymTransducer (SymPred '[] TinyCmd) '[] Bool TinyCmd ()+synth2Overlap =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = SymPred PTop,+                update = UKeep,+                output = [],+                target = True+              },+            Edge+              { guard = SymPred PTop,+                update = UKeep,+                output = [],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = (== True)+    }
+ test/Keiki/ValidationSpec.hs view
@@ -0,0 +1,261 @@+module Keiki.ValidationSpec (spec) where++import Data.List (isInfixOf)+import Data.Proxy (Proxy (..))+import Keiki.Core+import Keiki.Symbolic (checkDeadEdgesSym, checkTransitionDeterminismSym)+import Test.Hspec++-- A tiny two-constructor command for guards.+data Cmd = Foo | Bar+  deriving stock (Eq, Show)++inCtorFoo :: InCtor Cmd '[]+inCtorFoo =+  InCtor+    { icName = "Foo",+      icMatch = \case Foo -> Just RNil; _ -> Nothing,+      icBuild = \RNil -> Foo+    }++inCtorBar :: InCtor Cmd '[]+inCtorBar =+  InCtor+    { icName = "Bar",+      icMatch = \case Bar -> Just RNil; _ -> Nothing,+      icBuild = \RNil -> Bar+    }++-- A three-state enum: Start (reachable), Mid (reachable), Orphan (unreachable).+data V = Start | Mid | Orphan+  deriving stock (Eq, Ord, Show, Enum, Bounded)++-- (a) overlapping guards out of Start (both PTop).+overlapT :: SymTransducer (HsPred '[] Cmd) '[] V Cmd ()+overlapT =+  SymTransducer+    { edgesOut = \case+        Start ->+          [ Edge {guard = PTop, update = UKeep, output = [], target = Mid},+            Edge {guard = PTop, update = UKeep, output = [], target = Mid}+          ]+        _ -> [],+      initial = Start,+      initialRegs = RNil,+      isFinal = (== Mid)+    }++-- (b) an edge leaving the unreachable Orphan vertex.+deadT :: SymTransducer (HsPred '[] Cmd) '[] V Cmd ()+deadT =+  SymTransducer+    { edgesOut = \case+        Start -> [Edge {guard = matchInCtor inCtorFoo, update = UKeep, output = [], target = Mid}]+        Orphan -> [Edge {guard = PTop, update = UKeep, output = [], target = Start}]+        _ -> [],+      initial = Start,+      initialRegs = RNil,+      isFinal = (== Mid)+    }++-- (c) a literal-PBot guard on a reachable edge.+botT :: SymTransducer (HsPred '[] Cmd) '[] V Cmd ()+botT =+  SymTransducer+    { edgesOut = \case+        Start -> [Edge {guard = PBot, update = UKeep, output = [], target = Mid}]+        _ -> [],+      initial = Start,+      initialRegs = RNil,+      isFinal = (== Mid)+    }++-- (d) a clean transducer: mutually exclusive guards, every vertex with edges+-- is reachable, no overlapping/PBot guards. (Orphan has no outgoing edges, so+-- although it is structurally unreachable it contributes no edge to flag.)+cleanT :: SymTransducer (HsPred '[] Cmd) '[] V Cmd ()+cleanT =+  SymTransducer+    { edgesOut = \case+        Start ->+          [ Edge {guard = matchInCtor inCtorFoo, update = UKeep, output = [], target = Mid},+            Edge {guard = matchInCtor inCtorBar, update = UKeep, output = [], target = Mid}+          ]+        _ -> [],+      initial = Start,+      initialRegs = RNil,+      isFinal = (== Mid)+    }++-- (e) sym-only overlap: one PTop and one PInCtor edge out of Start. They DO+-- overlap (PTop always holds; the Foo guard holds on Foo) but the structural+-- pure path cannot prove it (neither both-PTop nor same-ctor), so only the+-- symbolic determinism check flags it.+symOverlapT :: SymTransducer (HsPred '[] Cmd) '[] V Cmd ()+symOverlapT =+  SymTransducer+    { edgesOut = \case+        Start ->+          [ Edge {guard = matchInCtor inCtorFoo, update = UKeep, output = [], target = Mid},+            Edge {guard = PTop, update = UKeep, output = [], target = Mid}+          ]+        _ -> [],+      initial = Start,+      initialRegs = RNil,+      isFinal = (== Mid)+    }++-- (f) an opaque collection-style guard (EP-67): the guard lifts list membership+-- through a TApp closure the symbolic analyses cannot see through. The register+-- slot holds a collection; the guard asks "is 5 in items?" via `elem`, which has+-- no structural keiki node, so it is forced through TApp1.+type ItemRegs = '[ '("items", [Int])]++opaqueT :: SymTransducer (HsPred ItemRegs Cmd) ItemRegs V Cmd ()+opaqueT =+  SymTransducer+    { edgesOut = \case+        Start ->+          [ Edge+              { guard =+                  PEq+                    (TApp1 (5 `elem`) (TReg (ZIdx :: Index ItemRegs [Int])))+                    (TLit True),+                update = UKeep,+                output = [],+                target = Mid+              }+          ]+        _ -> [],+      initial = Start,+      initialRegs = RCons (Proxy @"items") [] RNil,+      isFinal = (== Mid)+    }++-- A 3-slot input constructor, mirroring CoreHiddenInputsGSMSpec, used to build+-- a hidden-input edge (its output recovers only slots a, b — never c).+data MultiInput = Begin Int Int Int+  deriving stock (Eq, Show)++data MultiOutput = OutAB Int Int+  deriving stock (Eq, Show)++inCtorBegin :: InCtor MultiInput '[ '("a", Int), '("b", Int), '("c", Int)]+inCtorBegin =+  InCtor+    { icName = "Begin",+      icMatch = \case+        Begin a b c ->+          Just $+            RCons (Proxy @"a") a $+              RCons (Proxy @"b") b $+                RCons (Proxy @"c") c $+                  RNil,+      icBuild = \(RCons _ a (RCons _ b (RCons _ c RNil))) -> Begin a b c+    }++wcAB :: WireCtor MultiOutput (Int, (Int, ()))+wcAB =+  WireCtor+    { wcName = "OutAB",+      wcMatch = \case OutAB a b -> Just (a, (b, ())),+      wcBuild = \(a, (b, ())) -> OutAB a b+    }++-- A two-state transducer whose only edge recovers slots {a, b} but not {c},+-- so slot c is a hidden input.+hiddenT :: SymTransducer (HsPred '[] MultiInput) '[] Bool MultiInput MultiOutput+hiddenT =+  SymTransducer+    { edgesOut = \case+        False ->+          [ Edge+              { guard = matchInCtor inCtorBegin,+                update = UKeep,+                output =+                  [ pack+                      inCtorBegin+                      wcAB+                      ( OFCons+                          (TInpCtorField inCtorBegin (#a :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int))+                          (OFCons (TInpCtorField inCtorBegin (#b :: Index '[ '("a", Int), '("b", Int), '("c", Int)] Int)) OFNil)+                      )+                  ],+                target = True+              }+          ]+        True -> [],+      initial = False,+      initialRegs = RNil,+      isFinal = id+    }++spec :: Spec+spec = do+  describe "validateTransducer (pure, no solver)" $ do+    it "clean transducer yields no warnings" $+      validateTransducer defaultValidationOptions cleanT `shouldBe` []++    it "overlapping pair yields a NondeterministicPair naming both indices and source" $ do+      let isOverlapStart (NondeterministicPair {tvwSource = Start, tvwEdgeA = 0, tvwEdgeB = 1}) = True+          isOverlapStart _ = False+      filter isOverlapStart (validateTransducer defaultValidationOptions overlapT)+        `shouldSatisfy` (not . null)++    it "edge from an unreachable vertex yields a PossiblyDeadEdge" $ do+      let isDeadOrphan (PossiblyDeadEdge {tvwEdge = EdgeRef {edgeSource = Orphan, edgeIndex = 0}}) = True+          isDeadOrphan _ = False+      validateTransducer defaultValidationOptions deadT+        `shouldSatisfy` any isDeadOrphan++    it "literal-PBot guard on a reachable edge yields a PossiblyDeadEdge" $ do+      let isBotDead (PossiblyDeadEdge {tvwEdge = EdgeRef {edgeSource = Start, edgeIndex = 0}, tvwDetail = d}) =+            "unsatisfiable" `isInfixOf` d+          isBotDead _ = False+      validateTransducer defaultValidationOptions botT+        `shouldSatisfy` any isBotDead++  describe "validateTransducer hidden-input (structured)" $ do+    it "flags slot c as a hidden input with structured ctor/slot data" $ do+      let warnings = validateTransducer defaultValidationOptions hiddenT+          isHiddenC (HiddenInput {tvwEdge = EdgeRef {edgeSource = False, edgeIndex = 0}, tvwInCtor = Just "Begin", tvwMissingSlots = ms}) =+            "c" `elem` ms+          isHiddenC _ = False+      warnings `shouldSatisfy` any isHiddenC++  describe "ValidationOptions toggles" $ do+    it "disabling determinism suppresses NondeterministicPair" $ do+      let opts = defaultValidationOptions {checkDeterminism = False}+          isND (NondeterministicPair {}) = True+          isND _ = False+      filter isND (validateTransducer opts overlapT) `shouldBe` []++  describe "opaque-guard audit (EP-67, opt-in)" $ do+    let optsOn = defaultValidationOptions {warnOpaqueGuards = True}+        isOpaqueStart (OpaqueGuard {tvwEdge = EdgeRef {edgeSource = Start, edgeIndex = 0}}) = True+        isOpaqueStart _ = False++    it "an opaque collection-style guard is flagged when the audit is on" $+      validateTransducer optsOn opaqueT `shouldSatisfy` any isOpaqueStart++    it "a fully structural transducer is never flagged, even with the audit on" $ do+      let isOpaque (OpaqueGuard {}) = True+          isOpaque _ = False+      filter isOpaque (validateTransducer optsOn cleanT) `shouldBe` []++    it "the audit is silent under defaultValidationOptions (backward compat)" $+      validateTransducer defaultValidationOptions opaqueT `shouldBe` []++  describe "checkTransitionDeterminismSym (z3-backed)" $ do+    it "mutually-exclusive PInCtor guards yield no determinism warning" $+      checkTransitionDeterminismSym cleanT `shouldBe` []++    it "catches a PTop-vs-PInCtor overlap the pure path cannot prove" $ do+      checkTransitionDeterminismPure symOverlapT `shouldBe` []+      checkTransitionDeterminismSym symOverlapT `shouldSatisfy` (not . null)++  describe "checkDeadEdgesSym (z3-backed)" $ do+    it "flags a literal-PBot guard as unsatisfiable in isolation" $ do+      let isBotEdge (DeadEdgeWarning {dewEdge = EdgeRef {edgeSource = Start, edgeIndex = 0}}) = True+          isBotEdge _ = False+      checkDeadEdgesSym botT `shouldSatisfy` any isBotEdge
+ test/Spec.hs view
@@ -0,0 +1,72 @@+module Main (main) where++import Keiki.AcceptorSpec qualified+import Keiki.ArrowSpec qualified+import Keiki.BuilderSpec qualified+import Keiki.BuilderSpike qualified+import Keiki.CategorySpec qualified+import Keiki.ChoiceSpec qualified+import Keiki.CollectionSpike qualified+import Keiki.CompositionAlternativeSpec qualified+import Keiki.CompositionFeedback1Spec qualified+import Keiki.CompositionMultiEventSpec qualified+import Keiki.CompositionNarySpec qualified+import Keiki.CompositionSpec qualified+import Keiki.CoreApplyEventsSpec qualified+import Keiki.CoreHiddenInputsGSMSpec qualified+import Keiki.CoreInFlightSpec qualified+import Keiki.CoreSpec qualified+import Keiki.DeciderSpec qualified+import Keiki.Generics.THSpec qualified+import Keiki.NoThunksSpec qualified+import Keiki.OperatorsQualifiedSpec qualified+import Keiki.OperatorsSpec qualified+import Keiki.ProfunctorSpec qualified+import Keiki.RecomputeVerifySpec qualified+import Keiki.Render.InspectorSpec qualified+import Keiki.Render.MarkdownSpec qualified+import Keiki.Render.MermaidSpec qualified+import Keiki.Render.PrettySpec qualified+import Keiki.Render.ValidateSpec qualified+import Keiki.ShapeSpec qualified+import Keiki.StepEitherSpec qualified+import Keiki.StrongSpec qualified+import Keiki.SymbolicSpec qualified+import Keiki.ValidationSpec qualified+import Test.Hspec++main :: IO ()+main = hspec $ do+  describe "Keiki.Acceptor" Keiki.AcceptorSpec.spec+  describe "Keiki.Builder (EP-15 M6)" Keiki.BuilderSpec.spec+  describe "Keiki.BuilderSpike (EP-15 M2)" Keiki.BuilderSpike.spec+  describe "Keiki.Profunctor (Category, EP-28)" Keiki.CategorySpec.spec+  describe "Keiki.Profunctor (Choice, EP-29 M1)" Keiki.ChoiceSpec.spec+  describe "Keiki.Composition" Keiki.CompositionSpec.spec+  describe "Keiki.Composition (alternative, EP-25)" Keiki.CompositionAlternativeSpec.spec+  describe "Keiki.Composition (feedback1, EP-26)" Keiki.CompositionFeedback1Spec.spec+  describe "Keiki.Composition (multi-event, EP-19 M6)" Keiki.CompositionMultiEventSpec.spec+  describe "Keiki.Composition (N-ary codec, EP-48)" Keiki.CompositionNarySpec.spec+  describe "Keiki.Core" Keiki.CoreSpec.spec+  describe "Keiki.Core.stepEither (EP-55)" Keiki.StepEitherSpec.spec+  describe "Keiki.Core.applyEvents (EP-20 M2)" Keiki.CoreApplyEventsSpec.spec+  describe "Keiki.Core.InFlight / streaming (EP-19 M3)" Keiki.CoreInFlightSpec.spec+  describe "Keiki.Core.checkHiddenInputs (EP-19 M4 union)" Keiki.CoreHiddenInputsGSMSpec.spec+  describe "Keiki.Decider" Keiki.DeciderSpec.spec+  describe "Keiki.Generics.TH" Keiki.Generics.THSpec.spec+  describe "Keiki.NoThunks" Keiki.NoThunksSpec.spec+  describe "Keiki.Core operators (EP-45)" Keiki.OperatorsSpec.spec+  describe "Keiki.Operators (qualified import, EP-58)" Keiki.OperatorsQualifiedSpec.spec+  describe "Keiki.Profunctor (EP-27)" Keiki.ProfunctorSpec.spec+  describe "Keiki.Profunctor (Strong, EP-29 M2)" Keiki.StrongSpec.spec+  describe "Keiki.Profunctor (Arrow, EP-29 M3)" Keiki.ArrowSpec.spec+  describe "Keiki.RecomputeVerify (EP-47)" Keiki.RecomputeVerifySpec.spec+  describe "Keiki.Render.Inspector (EP-62)" Keiki.Render.InspectorSpec.spec+  describe "Keiki.Render.Markdown (EP-65)" Keiki.Render.MarkdownSpec.spec+  describe "Keiki.Render.Mermaid (EP-30, EP-31, EP-32, EP-33)" Keiki.Render.MermaidSpec.spec+  describe "Keiki.Render.Pretty (EP-61)" Keiki.Render.PrettySpec.spec+  describe "Keiki.Render.Validate (EP-66)" Keiki.Render.ValidateSpec.spec+  describe "Keiki.Shape (EP-36 M1)" Keiki.ShapeSpec.spec+  describe "Keiki.Symbolic" Keiki.SymbolicSpec.spec+  describe "Keiki.CollectionSpike (EP-60 M1 ratification gate)" Keiki.CollectionSpike.spec+  describe "Keiki.Core.validateTransducer (EP-56)" Keiki.ValidationSpec.spec