diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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` / `inp` / `is` + (singletons omit `inp`), defaulting each short-name suffix to + the constructor name. + - `deriveWireCtorsAll ''Event` — the event-side dual, emitting + `wire` plus, for record-payload events, the `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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/keiki.cabal b/keiki.cabal new file mode 100644 --- /dev/null +++ b/keiki.cabal @@ -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 diff --git a/src/Keiki/Acceptor.hs b/src/Keiki/Acceptor.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Acceptor.hs @@ -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 diff --git a/src/Keiki/Builder.hs b/src/Keiki/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Builder.hs @@ -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 +-- @\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 @\TermFields@ record (e.g. @EmailSentTermFields@) +-- is generated by 'Keiki.Generics.TH.deriveWireCtors' alongside the +-- existing @wire\@ 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 @\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 +-- @\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 [] diff --git a/src/Keiki/Composition.hs b/src/Keiki/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Composition.hs @@ -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) diff --git a/src/Keiki/Core.hs b/src/Keiki/Core.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Core.hs @@ -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: \"@ 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 + 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 diff --git a/src/Keiki/Decider.hs b/src/Keiki/Decider.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Decider.hs @@ -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 + } diff --git a/src/Keiki/Generics.hs b/src/Keiki/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Generics.hs @@ -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)) + } diff --git a/src/Keiki/Generics/TH.hs b/src/Keiki/Generics/TH.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Generics/TH.hs @@ -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 @\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@, @inp@, +-- @is@ 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\@, @inp\@, and @is\@ for +-- each constructor (singletons omit @inp\@). 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@ declarations from an event +-- sum type. Spec entries are @(constructorName, shortName)@ pairs. +-- A record-payload event also gets a @\TermFields@ helper +-- record plus its 'ToOutFields' instance. A singleton event gets only +-- the @wire\@ 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\@ (and, for record-payload +-- events, a @\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@ +-- and, for record-payload events, the @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: +-- @\"\"@ 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 binding + -- via mkWireCtor0 (no payload, so no 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 @@ whose fields are +-- @f1 :: T1@, @f2 :: T2@, ..., @fn :: Tn@, this emits two decls: +-- +-- > data TermFields rs ci = TermFields +-- > { f1 :: Term rs ci T1 +-- > , f2 :: Term rs ci T2 +-- > , ... +-- > } +-- +-- > instance ToOutFields (TermFields rs ci) rs ci +-- > (FieldsOf ) where +-- > toOutFields 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 @ 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 <> " }" diff --git a/src/Keiki/Internal/Slots.hs b/src/Keiki/Internal/Slots.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Internal/Slots.hs @@ -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) diff --git a/src/Keiki/NoThunks.hs b/src/Keiki/NoThunks.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/NoThunks.hs @@ -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 + ] diff --git a/src/Keiki/Operators.hs b/src/Keiki/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Operators.hs @@ -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. diff --git a/src/Keiki/Profunctor.hs b/src/Keiki/Profunctor.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Profunctor.hs @@ -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 + } diff --git a/src/Keiki/Render/Inspector.hs b/src/Keiki/Render/Inspector.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Render/Inspector.hs @@ -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 @### \@ 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 @### \@ 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: @\[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 @\
@ 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 diff --git a/src/Keiki/Render/Markdown.hs b/src/Keiki/Render/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Render/Markdown.hs @@ -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, +-- @\" + +-- | The end marker for a @(namespace, id)@ pair. +endMarker :: Text -> Text -> Text +endMarker ns i = + T.pack "" + +-- | 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') diff --git a/src/Keiki/Render/Mermaid.hs b/src/Keiki/Render/Mermaid.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Render/Mermaid.hs @@ -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 @
@-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, @
@ for three or more. +-- * 'MermaidOutputMultiline' — always one event per line +-- (@
@-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 @
@ 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 (@[*] --> @), one line per outgoing +-- edge of every vertex, and a final-state line (@ --> [*]@) +-- 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 \"\" as @ 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 \"\" as @ 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 +-- @_@. 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 +-- @\_\_\@ 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 \ { \ }@ block listing every +-- @\_\@ 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 \ { \ }@ block listing every +-- @\_\_\@ 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 \ { \ }@ block listing that arm's edges; +-- both arms share top-level @[*] --> \@ initial-state +-- markers and top-level @\ --> [*]@ 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 @\ / \@ 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 @\_\_\@. 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. +-- @\_\_\@. 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. +-- @\_\_\@ — 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 \"\" as @ 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\
e2\
…\
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, @
@ for three or +-- more. +-- * 'MermaidOutputMultiline' always joins with @
@. +-- * '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 "
") ns + render MermaidOutputMultiline ns = T.intercalate (T.pack "
") ns + render MermaidOutputCounted ns = T.pack (show (length ns) <> " events") + +-- | The Mermaid edge label for an edge: @ / @. +-- 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 +-- @ / @ 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 "
") (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 + -- @\") + fenced = + T.pack "```" + <> atlasFenceLanguage opts + <> T.pack "\n" + <> sectionDiagram sec + <> T.pack "\n```" + block = case atlasWrapMarkers opts of + Nothing -> fenced + Just ns -> + T.pack "\n" + <> fenced + <> T.pack "\n" + 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 diff --git a/src/Keiki/Render/Pretty.hs b/src/Keiki/Render/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Render/Pretty.hs @@ -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 @(...)@; literal +-- values render as @@ (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 @(...)@; literal +-- values render @@ (a 'TLit' carries an unconstrained type with no +-- 'Show'). +prettyTerm :: Term rs ci ifs r -> Text +prettyTerm (TLit _) = T.pack "" +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 "(" <> prettyTerm a <> T.pack ")" +prettyTerm (TApp2 _ a b) = + T.pack "(" <> 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 diff --git a/src/Keiki/Render/Validate.hs b/src/Keiki/Render/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Render/Validate.hs @@ -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 @\"
\"@ is always exempt from this check + -- regardless of what this set contains, because keiki emits @
@ + -- 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 \@ 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 @
@ so its angle brackets are not flagged as suspicious. +stripBrTags :: Text -> Text +stripBrTags = T.replace "
" " " + +-- | Collect @state \"\\" as \@ 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 \"\\" as \@ 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 [] = [] diff --git a/src/Keiki/Shape.hs b/src/Keiki/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Shape.hs @@ -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, +-- +-- > ":" ";" +-- +-- 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 @.@; 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)) + ] diff --git a/src/Keiki/Symbolic.hs b/src/Keiki/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/Keiki/Symbolic.hs @@ -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/\"@, +-- 'TInpCtorField' allocates @"inp/\/\"@). 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/\" + -- or "inp/\/\") 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/"@ where @slotName@ is the +-- slot's label recovered from the 'Index'\'s 'KnownSymbol' +-- evidence on its leaf 'ZIdx'. +-- * 'TInpCtorField' allocates +-- @"inp//"@ — 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 diff --git a/test/Keiki/AcceptorSpec.hs b/test/Keiki/AcceptorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/AcceptorSpec.hs @@ -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 diff --git a/test/Keiki/ArrowSpec.hs b/test/Keiki/ArrowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/ArrowSpec.hs @@ -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" diff --git a/test/Keiki/BuilderSpec.hs b/test/Keiki/BuilderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/BuilderSpec.hs @@ -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 " +showGuard (PInCtor _) = "PInCtor " + +-- * 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" diff --git a/test/Keiki/BuilderSpike.hs b/test/Keiki/BuilderSpike.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/BuilderSpike.hs @@ -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)) diff --git a/test/Keiki/CategorySpec.hs b/test/Keiki/CategorySpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CategorySpec.hs @@ -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" diff --git a/test/Keiki/ChoiceSpec.hs b/test/Keiki/ChoiceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/ChoiceSpec.hs @@ -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" diff --git a/test/Keiki/CollectionSpike.hs b/test/Keiki/CollectionSpike.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CollectionSpike.hs @@ -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 diff --git a/test/Keiki/CompositionAlternativeSpec.hs b/test/Keiki/CompositionAlternativeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CompositionAlternativeSpec.hs @@ -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_ <> ")" diff --git a/test/Keiki/CompositionFeedback1Spec.hs b/test/Keiki/CompositionFeedback1Spec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CompositionFeedback1Spec.hs @@ -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_ <> ")" diff --git a/test/Keiki/CompositionMultiEventSpec.hs b/test/Keiki/CompositionMultiEventSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CompositionMultiEventSpec.hs @@ -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) + ) diff --git a/test/Keiki/CompositionNarySpec.hs b/test/Keiki/CompositionNarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CompositionNarySpec.hs @@ -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 diff --git a/test/Keiki/CompositionSpec.hs b/test/Keiki/CompositionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CompositionSpec.hs @@ -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_ <> ")" diff --git a/test/Keiki/CoreApplyEventsSpec.hs b/test/Keiki/CoreApplyEventsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CoreApplyEventsSpec.hs @@ -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" diff --git a/test/Keiki/CoreHiddenInputsGSMSpec.hs b/test/Keiki/CoreHiddenInputsGSMSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CoreHiddenInputsGSMSpec.hs @@ -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" diff --git a/test/Keiki/CoreInFlightSpec.hs b/test/Keiki/CoreInFlightSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CoreInFlightSpec.hs @@ -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 <> ", _)" diff --git a/test/Keiki/CoreSpec.hs b/test/Keiki/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/CoreSpec.hs @@ -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) diff --git a/test/Keiki/DeciderSpec.hs b/test/Keiki/DeciderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/DeciderSpec.hs @@ -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)) diff --git a/test/Keiki/Fixtures/EmailDelivery.hs b/test/Keiki/Fixtures/EmailDelivery.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Fixtures/EmailDelivery.hs @@ -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: "@ 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 -> [] diff --git a/test/Keiki/Fixtures/UserRegistration.hs b/test/Keiki/Fixtures/UserRegistration.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Fixtures/UserRegistration.hs @@ -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: "@ 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//"@ 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 -> [] diff --git a/test/Keiki/Generics/THSpec.hs b/test/Keiki/Generics/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Generics/THSpec.hs @@ -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. diff --git a/test/Keiki/NoThunksSpec.hs b/test/Keiki/NoThunksSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/NoThunksSpec.hs @@ -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" diff --git a/test/Keiki/OperatorsQualifiedSpec.hs b/test/Keiki/OperatorsQualifiedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/OperatorsQualifiedSpec.hs @@ -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 diff --git a/test/Keiki/OperatorsSpec.hs b/test/Keiki/OperatorsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/OperatorsSpec.hs @@ -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] diff --git a/test/Keiki/ProfunctorSpec.hs b/test/Keiki/ProfunctorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/ProfunctorSpec.hs @@ -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) diff --git a/test/Keiki/RecomputeVerifySpec.hs b/test/Keiki/RecomputeVerifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/RecomputeVerifySpec.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE TemplateHaskell #-} +-- deriveAggregateCtors also emits an @is@ 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)) diff --git a/test/Keiki/Render/InspectorSpec.hs b/test/Keiki/Render/InspectorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Render/InspectorSpec.hs @@ -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" + ] diff --git a/test/Keiki/Render/MarkdownSpec.hs b/test/Keiki/Render/MarkdownSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Render/MarkdownSpec.hs @@ -0,0 +1,137 @@ +-- | Tests for "Keiki.Render.Markdown" (EP-65 M2). +-- +-- Exercises 'replaceMarkdownDiagramBlock': it rewrites exactly the span +-- between a matched pair of @\")) + + it "reports the expected end marker when only the begin is present" $ + replaceMarkdownDiagramBlock newBlock beginOnlyDoc + `shouldBe` Left (MissingEndMarker (T.pack "")) + + it "fails deterministically when the begin marker is duplicated" $ + replaceMarkdownDiagramBlock newBlock duplicateBeginDoc + `shouldBe` Left (DuplicateMarker (T.pack "") 2) + + it "fails deterministically when the end marker is duplicated" $ + replaceMarkdownDiagramBlock newBlock duplicateEndDoc + `shouldBe` Left (DuplicateMarker (T.pack "") 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.", + "", + "", + "```mermaid", + "OLD DIAGRAM", + "```", + "", + "", + "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.", + "", + "", + "```mermaid", + "stateDiagram-v2", + " [*] --> Open", + "```", + "", + "", + "Some prose below." + ] + +-- | A document with the begin marker but no matching end marker. +beginOnlyDoc :: Text +beginOnlyDoc = + T.intercalate + (T.pack "\n") + [ "", + "```mermaid", + "OLD DIAGRAM", + "```" + ] + +-- | A document whose begin marker appears twice. +duplicateBeginDoc :: Text +duplicateBeginDoc = + T.intercalate + (T.pack "\n") + [ "", + "", + "" + ] + +-- | A document whose end marker appears twice. +duplicateEndDoc :: Text +duplicateEndDoc = + T.intercalate + (T.pack "\n") + [ "", + "", + "" + ] diff --git a/test/Keiki/Render/MermaidSpec.hs b/test/Keiki/Render/MermaidSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Render/MermaidSpec.hs @@ -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
-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 @
@-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
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-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 @
@ (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
B
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
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
B
C", + " MS1 --> MS2 : Go / A
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 "\n\n", + T.pack "\n", + T.pack "```mermaid\n", + userRegCanonical, + T.pack "\n```", + T.pack "\n", + T.pack "\n\n", + T.pack "## Dispatch\n\n", + T.pack "\n\n", + T.pack "\n", + T.pack "```mermaid\n", + alertEmailCompositeCanonical, + T.pack "\n```", + T.pack "\n" + ] + +-- | 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 +-- @\_\@ 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 +-- @\_\_\@. 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-@
@ 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 + } diff --git a/test/Keiki/Render/PrettySpec.hs b/test/Keiki/Render/PrettySpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Render/PrettySpec.hs @@ -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 " $ + prettyTerm (TLit (42 :: Int) :: Term Regs Cmd '[] Int) + `shouldBe` T.pack "" + it "renders TApp1 as (arg)" $ + prettyTerm (TApp1 (+ (1 :: Int)) (TReg balanceIx) :: Term Regs Cmd '[] Int) + `shouldBe` T.pack "(balance)" + it "renders TApp2 as (a, b)" $ + prettyTerm + ( TApp2 ((+) :: Int -> Int -> Int) (TReg balanceIx) (TReg limitIx) :: + Term Regs Cmd '[] Int + ) + `shouldBe` T.pack "(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 on the literal side" $ + prettyPred (PEq (TReg balanceIx) (TLit (0 :: Int)) :: HsPred Regs Cmd) + `shouldBe` T.pack "balance == " + 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 >= || !(limit == )))" + + 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 := " + 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 := " diff --git a/test/Keiki/Render/ValidateSpec.hs b/test/Keiki/Render/ValidateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Render/ValidateSpec.hs @@ -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
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 @
@ tag, +-- which the validator exempts. +brDiagram :: Text +brDiagram = + T.intercalate + (T.pack "\n") + [ "stateDiagram-v2", + " [*] --> S1", + " S1 --> S2 : Cmd / A
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 --> [*]", + "```" + ] diff --git a/test/Keiki/ShapeSpec.hs b/test/Keiki/ShapeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/ShapeSpec.hs @@ -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" diff --git a/test/Keiki/StepEitherSpec.hs b/test/Keiki/StepEitherSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/StepEitherSpec.hs @@ -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) diff --git a/test/Keiki/StrongSpec.hs b/test/Keiki/StrongSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/StrongSpec.hs @@ -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" diff --git a/test/Keiki/SymbolicSpec.hs b/test/Keiki/SymbolicSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/SymbolicSpec.hs @@ -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) + } diff --git a/test/Keiki/ValidationSpec.hs b/test/Keiki/ValidationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/ValidationSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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