keiro-dsl 0.7.0.0 → 0.8.0.0

raw patch · 26 files changed

+4162/−2184 lines, 26 filesdep ~keiro-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: keiro-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +37/−0
• keiro-dsl.cabal +26/−2
• src/Keiro/Dsl/Frontend.hs +42/−0
• src/Keiro/Dsl/Frontend/Internal.hs +307/−0
• src/Keiro/Dsl/LanguageVersion.hs +66/−12
• src/Keiro/Dsl/Parser.hs +39/−2165
• src/Keiro/Dsl/Parser/Aggregate.hs +337/−0
• src/Keiro/Dsl/Parser/Coordination.hs +311/−0
• src/Keiro/Dsl/Parser/Core.hs +450/−0
• src/Keiro/Dsl/Parser/Declaration.hs +73/−0
• src/Keiro/Dsl/Parser/Document.hs +147/−0
• src/Keiro/Dsl/Parser/Expression.hs +149/−0
• src/Keiro/Dsl/Parser/Integration.hs +241/−0
• src/Keiro/Dsl/Parser/Mapped.hs +323/−0
• src/Keiro/Dsl/Parser/Preamble.hs +117/−0
• src/Keiro/Dsl/Parser/Queue.hs +147/−0
• src/Keiro/Dsl/Parser/ReadModel.hs +60/−0
• src/Keiro/Dsl/Parser/Workflow.hs +135/−0
• src/Keiro/Dsl/SemanticContract.hs +3/−5
• src/Keiro/Dsl/Source.hs +76/−0
• src/Keiro/Dsl/Syntax.hs +69/−0
• test/Keiro/Dsl/FrontendCompatibility.hs +468/−0
• test/Keiro/Dsl/FrontendProfiles.hs +191/−0
• test/Keiro/Dsl/FrontendPublicApiProbe.hs +77/−0
• test/Keiro/Dsl/FrontendSurface.hs +264/−0
• test/Main.hs +7/−0

@@ -6,6 +6,43 @@  ## [Unreleased] +## 0.8.0.0 — 2026-08-01++### Breaking Changes++- `LanguageDefinition` gains two fields — `definitionSyntaxProfile` and+  `definitionRuntimeSemantics`. The type is exported as `LanguageDefinition (..)` from+  `Keiro.Dsl.LanguageVersion`, so positional construction and non-wildcard record patterns no longer+  compile. `definitionBodyParser` is retained as a compatibility projection but is no longer+  consulted for parser dispatch.++### New Features++- Adds the public `Keiro.Dsl.Source`, `Keiro.Dsl.Syntax`, and `Keiro.Dsl.Frontend` advanced API.+  Source-aware tooling can parse an ordered, located `SurfaceSource`, inspect exact half-open spans,+  and lower explicitly to the existing `ParsedSource`/`Spec` semantic boundary.+- Adds structured frontend failures with source-selection, body-parsing, and lowering phases;+  stable codes; exact primary spans; messages; expected items; and supported-version metadata.+  Megaparsec types remain internal.+- Adds `syntaxProfileIdentifier`, `syntaxProfileSupportsFeature`,+  `languageVersionsSupportingFeature`, and `sourceLanguageDiagnosticMessage` to+  `Keiro.Dsl.LanguageVersion`.++### Other Changes++- Organizes the `.keiro` grammar into internal concern modules behind the stable+  `Keiro.Dsl.Parser` compatibility facade. CLI and workspace members still parse once through that+  facade; semantic checking, scaffolding, diffing, fingerprints, and replay consume only lowered+  semantic values.+- Makes every released registry entry explicitly select an immutable syntax profile and runtime-+  semantics identity. Version 3 deliberately reuses version 2's syntax profile; adding a future+  version no longer inherits syntax or runtime behavior from numeric ordering.+- Keeps `parseSource`, `parseSpec`, `parseSpecText`, their rendered diagnostics, the complete 0.7+  acceptance matrix, and generated Haskell bytes unchanged. Canonical pretty printing remains+  non-lossless: the located surface layer does not retain comments or whitespace.+- Derives `languageFeatureMinimumVersion` and `languageSupportsFeature` from the registry's syntax+  profiles instead of numeric version ordering.+ ## 0.7.0.0 — 2026-08-01  ### Breaking Changes

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            keiro-dsl-version:         0.7.0.0+version:         0.8.0.0 synopsis:        Typed specification toolchain for keiro services description:   keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro@@ -42,6 +42,7 @@     Keiro.Dsl.ExplainBindings     Keiro.Dsl.Expression     Keiro.Dsl.FoldFingerprint+    Keiro.Dsl.Frontend     Keiro.Dsl.Goldens     Keiro.Dsl.Grammar     Keiro.Dsl.Harness@@ -60,6 +61,8 @@     Keiro.Dsl.ScaffoldRun     Keiro.Dsl.SemanticContract     Keiro.Dsl.Skeleton+    Keiro.Dsl.Source+    Keiro.Dsl.Syntax     Keiro.Dsl.TypeGraph     Keiro.Dsl.Validate     Keiro.Dsl.Workspace@@ -68,6 +71,21 @@     Keiro.Dsl.WorkspaceRecord     Keiro.Dsl.WorkspaceScaffold +  other-modules:+    Keiro.Dsl.Frontend.Internal+    Keiro.Dsl.Parser.Aggregate+    Keiro.Dsl.Parser.Coordination+    Keiro.Dsl.Parser.Core+    Keiro.Dsl.Parser.Declaration+    Keiro.Dsl.Parser.Document+    Keiro.Dsl.Parser.Expression+    Keiro.Dsl.Parser.Integration+    Keiro.Dsl.Parser.Mapped+    Keiro.Dsl.Parser.Preamble+    Keiro.Dsl.Parser.Queue+    Keiro.Dsl.Parser.ReadModel+    Keiro.Dsl.Parser.Workflow+   build-depends:     , aeson               >=2.2.1    && <2.3     , base                >=4.21     && <5@@ -76,7 +94,7 @@     , directory           >=1.3      && <1.4     , filepath            >=1.4      && <1.6     , keiki               >=0.7      && <0.8-    , keiro-core          ^>=0.7.0.0+    , keiro-core          ^>=0.8.0.0     , megaparsec          >=9.6      && <9.9     , mmzk-typeid         >=0.7      && <0.8     , parser-combinators  >=1.3      && <1.4@@ -103,6 +121,12 @@   type:           exitcode-stdio-1.0   hs-source-dirs: test   main-is:        Main.hs+  other-modules:+    Keiro.Dsl.FrontendCompatibility+    Keiro.Dsl.FrontendProfiles+    Keiro.Dsl.FrontendPublicApiProbe+    Keiro.Dsl.FrontendSurface+   build-depends:     , aeson       >=2.2  && <2.3     , base        >=4.21 && <5

@@ -0,0 +1,42 @@+-- | Advanced source-aware entry points for the Keiro DSL frontend.+--+-- Ordinary callers can continue to use "Keiro.Dsl.Parser". This module owns+-- the located surface/lowering seam without exposing Megaparsec.+--+-- A source-aware caller parses once, inspects exact half-open spans, and then+-- lowers into the same 'Keiro.Dsl.LanguageVersion.ParsedSource' returned by+-- the compatibility facade:+--+-- @+-- case parseSurfaceSource "orders.keiro" input of+--   Left failure -> renderFrontendFailure failure+--   Right surface ->+--     case lowerSurfaceSource surface of+--       Left loweringFailure -> renderLoweringFailure loweringFailure+--       Right _parsed -> "ready for semantic checking"+-- @+--+-- Pattern matching on 'Keiro.Dsl.Source.SourceSpan' exposes source name,+-- token offsets, and one-based line/column points. The surface tree does not+-- retain comments or whitespace; canonical pretty printing is therefore not+-- a lossless source formatter.+module Keiro.Dsl.Frontend+  ( FrontendContext (..),+    frontendLanguageVersion,+    frontendSupportsFeature,+    FrontendPhase (..),+    FrontendErrorCode (..),+    frontendErrorCodeText,+    FrontendFailure (..),+    renderFrontendFailure,+    LoweringFailureCode (..),+    LoweringFailure (..),+    renderLoweringFailure,+    frontendFailureFromLowering,+    parseSurfaceSource,+    lowerSurfaceSource,+  )+where++import Keiro.Dsl.Frontend.Internal+import Keiro.Dsl.Parser.Document (parseSurfaceSource)

@@ -0,0 +1,307 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | Shared implementation behind the public frontend and parser compatibility+-- facade. This module is intentionally not exposed by the package.+module Keiro.Dsl.Frontend.Internal+  ( FrontendContext (..),+    frontendLanguageVersion,+    frontendSupportsFeature,+    FrontendPhase (..),+    FrontendErrorCode (..),+    frontendErrorCodeText,+    FrontendFailure (..),+    frontendCompatibilityFailure,+    frontendFailureFromSourceDiagnostic,+    frontendFailureFromBody,+    frontendFailureFromLowering,+    renderFrontendFailure,+    LoweringFailureCode (..),+    LoweringFailure (..),+    renderLoweringFailure,+    lowerSurfaceSource,+  )+where++import Data.Foldable (traverse_)+import Data.List (find)+import Data.List.NonEmpty qualified as NE+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+  ( LanguageDefinition,+    LanguageFeature,+    LanguageVersion,+    ParseFailure (..),+    ParsedSource (..),+    SourceLanguage,+    SourceLanguageDiagnostic (..),+    SourceLanguageErrorCode,+    definitionVersion,+    languageSupportsFeature,+    renderParseFailure,+    sourceLanguageDiagnosticMessage,+    sourceLanguageErrorCodeText,+  )+import Keiro.Dsl.Source+import Keiro.Dsl.Syntax+import Prelude hiding (span)++-- | The single released-language selection threaded through the modular+-- grammar. Grammar productions ask this context about exact profile+-- membership rather than comparing version numbers.+data FrontendContext = FrontendContext+  { source :: !FilePath,+    language :: !SourceLanguage,+    definition :: !LanguageDefinition+  }+  deriving stock (Eq, Show, Generic)++frontendLanguageVersion :: FrontendContext -> LanguageVersion+frontendLanguageVersion FrontendContext {definition} = definitionVersion definition++frontendSupportsFeature :: FrontendContext -> LanguageFeature -> Bool+frontendSupportsFeature context feature = languageSupportsFeature (frontendLanguageVersion context) feature++data FrontendPhase+  = SourceSelectionPhase+  | BodyParsingPhase+  | LoweringPhase+  deriving stock (Eq, Ord, Show, Generic)++data FrontendErrorCode+  = SourceLanguageError !SourceLanguageErrorCode+  | SourceSelectionSyntaxError+  | BodySyntaxError+  | LoweringError !LoweringFailureCode+  deriving stock (Eq, Ord, Show, Generic)++frontendErrorCodeText :: FrontendErrorCode -> Text+frontendErrorCodeText = \case+  SourceLanguageError code -> sourceLanguageErrorCodeText code+  SourceSelectionSyntaxError -> "SourceSelectionSyntaxError"+  BodySyntaxError -> "BodySyntaxError"+  LoweringError code -> T.pack (show code)++-- | A source-aware frontend failure. The compatibility projection is retained+-- as data so the released parser facade can render byte-identical diagnostics+-- without exposing Megaparsec types.+data FrontendFailure = FrontendFailure+  { phase :: !FrontendPhase,+    code :: !FrontendErrorCode,+    span :: !SourceSpan,+    message :: !Text,+    expected :: ![Text],+    supportedVersions :: ![LanguageVersion],+    compatibility :: !ParseFailure+  }+  deriving stock (Eq, Show, Generic)++renderFrontendFailure :: FrontendFailure -> Text+renderFrontendFailure FrontendFailure {compatibility} = renderParseFailure compatibility++frontendCompatibilityFailure :: FrontendFailure -> ParseFailure+frontendCompatibilityFailure FrontendFailure {compatibility} = compatibility++frontendFailureFromSourceDiagnostic :: FrontendPhase -> SourceSpan -> Maybe [LanguageVersion] -> SourceLanguageDiagnostic -> FrontendFailure+frontendFailureFromSourceDiagnostic phase span supportedOverride diagnostic =+  FrontendFailure+    { phase,+      code = SourceLanguageError (sourceLanguageErrorCode diagnostic),+      span,+      message = sourceLanguageDiagnosticMessage diagnostic,+      expected = [],+      supportedVersions = fromMaybe (NE.toList (sourceLanguageSupportedVersions diagnostic)) supportedOverride,+      compatibility = SourceLanguageFailure diagnostic+    }++frontendFailureFromBody :: FrontendPhase -> SourceSpan -> Text -> [Text] -> ParseFailure -> FrontendFailure+frontendFailureFromBody phase span message expected compatibility =+  FrontendFailure+    { phase,+      code = case phase of+        SourceSelectionPhase -> SourceSelectionSyntaxError+        BodyParsingPhase -> BodySyntaxError+        LoweringPhase -> BodySyntaxError,+      span,+      message,+      expected,+      supportedVersions = [],+      compatibility+    }++data LoweringFailureCode+  = InvalidSourceSpan+  | SourceNameMismatch+  | SurfaceOrderInvalid+  deriving stock (Eq, Ord, Show, Generic)++-- | A failure found while converting surface evidence to the semantic graph.+data LoweringFailure = LoweringFailure+  { code :: !LoweringFailureCode,+    span :: !SourceSpan,+    message :: !Text+  }+  deriving stock (Eq, Show, Generic)++renderLoweringFailure :: LoweringFailure -> Text+renderLoweringFailure+  LoweringFailure+    { code,+      span = SourceSpan {source, start = SourcePoint {line, column}},+      message+    } =+    T.pack source+      <> ":"+      <> T.pack (show line)+      <> ":"+      <> T.pack (show column)+      <> ": error ["+      <> T.pack (show code)+      <> "]: "+      <> message++frontendFailureFromLowering :: LoweringFailure -> FrontendFailure+frontendFailureFromLowering failure@LoweringFailure {code, span, message} =+  FrontendFailure+    { phase = LoweringPhase,+      code = LoweringError code,+      span,+      message,+      expected = [],+      supportedVersions = [],+      compatibility = BodyGrammarFailure (renderLoweringFailure failure)+    }++-- | Remove document order and exact locations while projecting each top-level+-- span's starting line into the compatibility 'Loc'.+lowerSurfaceSource :: SurfaceSource -> Either LoweringFailure ParsedSource+lowerSurfaceSource surfaceSource@SurfaceSource {language, spec = locatedSpec} = do+  validateSurfaceSource surfaceSource+  pure+    ParsedSource+      { parsedSourceLanguage = language,+        parsedSpec = lowerSpec locatedSpec+      }++lowerSpec :: Located SurfaceSpec -> Spec+lowerSpec+  Located+    { value =+        SurfaceSpec+          { context = Located {value = contextName},+            moduleRoot,+            layout,+            items+          }+    } =+    Spec+      { specContext = contextName,+        specModuleRoot = locatedValue <$> moduleRoot,+        specLayout = locatedValue <$> layout,+        specIds = [declaration | Located {span, value = SurfaceId value} <- items, let declaration = value {idLoc = spanLoc span}],+        specEnums = [declaration | Located {span, value = SurfaceEnum value} <- items, let declaration = value {enumLoc = spanLoc span}],+        specRules = [declaration | Located {span, value = SurfaceRule value} <- items, let declaration = value {ruleLoc = spanLoc span}],+        specNominalScalars = [declaration | Located {span, value = SurfaceNominalScalar value} <- items, let declaration = value {nominalScalarLoc = spanLoc span}],+        specMapped = [declaration | Located {span, value = SurfaceMapped value} <- items, let declaration = setMappedLoc (spanLoc span) value],+        specNodes = [node | Located {span, value = SurfaceNode value} <- items, let node = setNodeLoc (spanLoc span) value]+      }++locatedValue :: Located a -> a+locatedValue Located {value} = value++spanLoc :: SourceSpan -> Loc+spanLoc sourceSpan = Loc (startLine sourceSpan)++setMappedLoc :: Loc -> MappedDecl -> MappedDecl+setMappedLoc loc value@MappedStructural {} = value {msLoc = loc}+setMappedLoc loc value@MappedOpaque {} = value {moLoc = loc}++setNodeLoc :: Loc -> Node -> Node+setNodeLoc loc = \case+  NAggregate value -> NAggregate value {aggLoc = loc}+  NProcess value -> NProcess value {procLoc = loc}+  NRouter value -> NRouter value {rtLoc = loc}+  NContract value -> NContract value {ctrLoc = loc}+  NIntake value -> NIntake value {inkLoc = loc}+  NEmit value -> NEmit value {emLoc = loc}+  NPublisher value -> NPublisher value {pubLoc = loc}+  NWorkqueue value -> NWorkqueue value {wqLoc = loc}+  NPgmqDispatch value -> NPgmqDispatch value {pdLoc = loc}+  NReadModel value -> NReadModel value {rmLoc = loc}+  NWorkflow+    WorkflowNode+      { wfId,+        wfStable,+        wfInput,+        wfInputFields,+        wfOutput,+        wfIdField,+        wfIdVia,+        wfBody+      } ->+      NWorkflow+        WorkflowNode+          { wfId,+            wfStable,+            wfInput,+            wfInputFields,+            wfOutput,+            wfIdField,+            wfIdVia,+            wfBody,+            wfLoc = loc+          }+  NOperation value -> NOperation value {opLoc = loc}++validateSurfaceSource :: SurfaceSource -> Either LoweringFailure ()+validateSurfaceSource+  SurfaceSource+    { source = sourceName,+      preamble,+      spec = Located {span = specSpan, value = surfaceSpec}+    } = do+    traverse_ (validateOwnedSpan sourceName) allSpans+    traverse_ (validateContained specSpan) bodySpans+    validateOrder (surfaceItemSpans surfaceSpec)+    where+      bodySpans = surfaceSpecSpans surfaceSpec+      allSpans = specSpan : maybe [] (\Located {span} -> [span]) preamble <> bodySpans+      validateOwnedSpan expected sourceSpan@SourceSpan {source}+        | not (validSourceSpan sourceSpan) =+            Left LoweringFailure {code = InvalidSourceSpan, span = sourceSpan, message = "source span end precedes its start"}+        | source /= expected =+            Left LoweringFailure {code = SourceNameMismatch, span = sourceSpan, message = "surface span belongs to a different source"}+        | otherwise = Right ()+      validateContained outer inner+        | contains outer inner = Right ()+        | otherwise = Left LoweringFailure {code = InvalidSourceSpan, span = inner, message = "surface element lies outside the document body span"}++surfaceSpecSpans :: SurfaceSpec -> [SourceSpan]+surfaceSpecSpans SurfaceSpec {context = Located {span = contextSpan}, moduleRoot, layout, items, elements} =+  contextSpan+    : maybe [] (\Located {span} -> [span]) moduleRoot+      <> maybe [] (\Located {span} -> [span]) layout+      <> map (\Located {span} -> span) items+      <> map (\Located {span} -> span) elements++surfaceItemSpans :: SurfaceSpec -> [SourceSpan]+surfaceItemSpans SurfaceSpec {items} = map (\Located {span} -> span) items++contains :: SourceSpan -> SourceSpan -> Bool+contains+  SourceSpan {start = outerStart, end = outerEnd}+  SourceSpan {start = innerStart, end = innerEnd} =+    outerStart <= innerStart && innerEnd <= outerEnd++validateOrder :: [SourceSpan] -> Either LoweringFailure ()+validateOrder spans =+  case find outOfOrder (zip spans (drop 1 spans)) of+    Nothing -> Right ()+    Just (_, offendingSpan) ->+      Left LoweringFailure {code = SurfaceOrderInvalid, span = offendingSpan, message = "top-level surface items are not in source order"}+  where+    outOfOrder (SourceSpan {start = previousStart}, SourceSpan {start = nextStart}) = previousStart > nextStart

@@ -14,16 +14,21 @@     declaredLanguageVersionMaybe,     effectiveLanguageVersion,     LanguageBodyParser (..),+    SyntaxProfile,+    syntaxProfileIdentifier,+    syntaxProfileSupportsFeature,     LanguageDefinition (..),     languageRegistry,     supportedLanguageVersions,     lookupLanguageDefinition,     LanguageFeature (..),     languageFeatureMinimumVersion,+    languageVersionsSupportingFeature,     languageSupportsFeature,     SourceLanguageErrorCode (..),     sourceLanguageErrorCodeText,     SourceLanguageDiagnostic (..),+    sourceLanguageDiagnosticMessage,     renderSourceLanguageDiagnostic,     ParsedSource (..),     ParseFailure (..),@@ -35,8 +40,11 @@ import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE+import Data.Set (Set)+import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T+import GHC.Generics (Generic) import Keiro.Dsl.Grammar (Loc (..), Spec, noLoc) import Numeric.Natural (Natural) @@ -90,13 +98,32 @@   | LanguageBodyParserV2   deriving stock (Eq, Show) +-- | An immutable, explicitly named set of source-language capabilities.+-- Constructors stay private so a released profile can only be selected from+-- the authoritative registry rather than widened ad hoc by parser callers.+data SyntaxProfile = SyntaxProfile+  { profileIdentifier :: !Text,+    profileFeatures :: !(Set LanguageFeature)+  }+  deriving stock (Eq, Show, Generic)++syntaxProfileIdentifier :: SyntaxProfile -> Text+syntaxProfileIdentifier SyntaxProfile {profileIdentifier} = profileIdentifier++syntaxProfileSupportsFeature :: SyntaxProfile -> LanguageFeature -> Bool+syntaxProfileSupportsFeature SyntaxProfile {profileFeatures} feature = Set.member feature profileFeatures+ -- | One append-only released-language registry entry. data LanguageDefinition = LanguageDefinition   { definitionVersion :: !LanguageVersion,     definitionPredecessor :: !(Maybe LanguageVersion),-    definitionBodyParser :: !LanguageBodyParser+    -- | Compatibility projection retained for the 0.7 public API. Parser+    -- dispatch uses 'definitionSyntaxProfile', never this historical tag.+    definitionBodyParser :: !LanguageBodyParser,+    definitionSyntaxProfile :: !SyntaxProfile,+    definitionRuntimeSemantics :: !Text   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Show, Generic)  version1 :: LanguageVersion version1 = LanguageVersion 1@@ -110,11 +137,26 @@ -- | The authoritative, append-only registry of released language contracts. languageRegistry :: NonEmpty LanguageDefinition languageRegistry =-  LanguageDefinition version1 Nothing LanguageBodyParserV1-    :| [ LanguageDefinition version2 (Just version1) LanguageBodyParserV2,-         LanguageDefinition version3 (Just version2) LanguageBodyParserV2+  LanguageDefinition version1 Nothing LanguageBodyParserV1 profileV1 "keiro-dsl/runtime-semantics/1"+    :| [ LanguageDefinition version2 (Just version1) LanguageBodyParserV2 profileV2 "keiro-dsl/runtime-semantics/1",+         LanguageDefinition version3 (Just version2) LanguageBodyParserV2 profileV2 "keiro-dsl/runtime-semantics/2"        ] +profileV1 :: SyntaxProfile+profileV1 = SyntaxProfile "keiro-dsl/syntax-profile/1" Set.empty++profileV2 :: SyntaxProfile+profileV2 =+  SyntaxProfile+    "keiro-dsl/syntax-profile/2"+    ( Set.fromList+        [ NominalBindingSyntax,+          IntegerScalarSyntax,+          TypedAggregateExpressionSyntax,+          ExplicitTransitionImplementationSyntax+        ]+    )+ -- | Supported versions, derived from 'languageRegistry'. supportedLanguageVersions :: NonEmpty LanguageVersion supportedLanguageVersions = definitionVersion <$> languageRegistry@@ -135,14 +177,21 @@  -- | The first released contract that owns each grammar feature. languageFeatureMinimumVersion :: LanguageFeature -> LanguageVersion-languageFeatureMinimumVersion = \case-  NominalBindingSyntax -> version2-  IntegerScalarSyntax -> version2-  TypedAggregateExpressionSyntax -> version2-  ExplicitTransitionImplementationSyntax -> version2+languageFeatureMinimumVersion feature =+  case find (\definition -> syntaxProfileSupportsFeature (definitionSyntaxProfile definition) feature) (NE.toList languageRegistry) of+    Just definition -> definitionVersion definition+    Nothing -> error "keiro-dsl internal invariant: a released language feature has no owning profile" +languageVersionsSupportingFeature :: LanguageFeature -> [LanguageVersion]+languageVersionsSupportingFeature feature =+  [ definitionVersion definition+  | definition <- NE.toList languageRegistry,+    syntaxProfileSupportsFeature (definitionSyntaxProfile definition) feature+  ]+ languageSupportsFeature :: LanguageVersion -> LanguageFeature -> Bool-languageSupportsFeature version feature = version >= languageFeatureMinimumVersion feature+languageSupportsFeature version feature =+  maybe False (\definition -> syntaxProfileSupportsFeature (definitionSyntaxProfile definition) feature) (lookupLanguageDefinition version)  effectiveLanguageVersion :: SourceLanguage -> LanguageVersion effectiveLanguageVersion LegacyUnversioned = version1@@ -203,9 +252,14 @@     <> ":1: error ["     <> sourceLanguageErrorCodeText code     <> "]: "-    <> detail+    <> sourceLanguageDiagnosticMessage diagnostic   where     Loc line = sourceLanguageLoc diagnostic+    code = sourceLanguageErrorCode diagnostic++sourceLanguageDiagnosticMessage :: SourceLanguageDiagnostic -> Text+sourceLanguageDiagnosticMessage diagnostic = detail+  where     code = sourceLanguageErrorCode diagnostic     supported = T.intercalate ", " (map languageVersionText (NE.toList (sourceLanguageSupportedVersions diagnostic)))     token = maybe "<missing>" id (sourceLanguageToken diagnostic)

@@ -1,2165 +1,39 @@--- | The megaparsec parser for the keiro DSL. Turns @.keiro@ text into the typed--- 'Spec' AST. The notation is keyword-driven: newlines and @#@-comments are--- whitespace, structure comes from keywords (@aggregate@, @regs@, @states@,--- @command@, @event@, @wire@, @projection@) and the transition arrow--- @Src -- Command --> clauses@. Guards and write right-hand sides are parsed as--- a typed 'Expr' (never an opaque string) so the validator can scope-check them.-module Keiro.Dsl.Parser-  ( ParseError,-    ParseFailure (..),-    ParsedSource (..),-    parseSource,-    parseSpec,-    parseSpecText,-    renderParseFailure,-  )-where--import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)-import Data.Bifunctor (first)-import Data.Char (isAlpha, isAlphaNum, isAscii, isDigit, isUpper)-import Data.List.NonEmpty qualified as NE-import Data.Maybe (mapMaybe)-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import Data.Text.Read qualified as TR-import Keiro.Dsl.Grammar-import Keiro.Dsl.LanguageVersion-import Numeric.Natural (Natural)-import Text.Megaparsec hiding (ParseError)-import Text.Megaparsec.Char (char, digitChar, letterChar, space1)-import Text.Megaparsec.Char.Lexer qualified as L---- | A rendered, line-numbered parse error, ready to print to the user.-type ParseError = Text--data ContextualParseFailure = ContextualParseFailure-  { contextualFailureCode :: !SourceLanguageErrorCode,-    contextualFailureLine :: !Int-  }-  deriving stock (Eq, Ord, Show)--instance ShowErrorComponent ContextualParseFailure where-  showErrorComponent contextual = T.unpack (sourceLanguageErrorCodeText (contextualFailureCode contextual))--type P = Parsec ContextualParseFailure Text---- | Parse a @.keiro@ source. The 'FilePath' is used only as the source name in--- diagnostics (megaparsec's line/column reporting); it need not exist on disk.--- This is the canonical signature shared across all keiro-dsl plans.-parseSpec :: FilePath -> Text -> Either ParseError Spec-parseSpec src input = parsedSpec <$> first renderParseFailure (parseSource src input)---- | Convenience wrapper for callers without a source name (tests, stdin).-parseSpecText :: Text -> Either ParseError Spec-parseSpecText = parseSpec "<input>"---- | Parse a source without discarding the language contract selected for it.--- Source selection completes before the selected body grammar is run.-parseSource :: FilePath -> Text -> Either ParseFailure ParsedSource-parseSource src input = do-  sourceLanguage <- selectSourceLanguage src input-  definition <- case lookupLanguageDefinition (effectiveLanguageVersion sourceLanguage) of-    Just value -> Right value-    Nothing -> Left (unsupportedDiagnostic src sourceLanguage)-  spec <- parseSelectedBody definition sourceLanguage-  pure ParsedSource {parsedSourceLanguage = sourceLanguage, parsedSpec = spec}-  where-    parseSelectedBody definition sourceLanguage =-      let version = definitionVersion definition-          laterPreambleCode = case sourceLanguage of-            LegacyUnversioned -> MisplacedLanguagePreamble-            DeclaredLanguage {} -> DuplicateLanguagePreamble-          parser = case definitionBodyParser definition of-            LanguageBodyParserV1 ->-              sc-                *> case sourceLanguage of-                  LegacyUnversioned -> pSpec version laterPreambleCode <* eof-                  DeclaredLanguage {} -> pDeclaredPreamble *> pSpec version laterPreambleCode <* eof-            LanguageBodyParserV2 ->-              sc *> pDeclaredPreamble *> pSpec version laterPreambleCode <* eof-       in case runParser parser src input of-            Left bundle -> case firstContextualFailure bundle of-              Just contextual -> Left (SourceLanguageFailure (contextualDiagnostic src sourceLanguage contextual))-              Nothing -> Left (BodyGrammarFailure (T.pack (errorBundlePretty bundle)))-            Right spec -> Right spec--firstContextualFailure :: ParseErrorBundle Text ContextualParseFailure -> Maybe ContextualParseFailure-firstContextualFailure bundle =-  case [ contextual-       | FancyError _ fancy <- NE.toList (bundleErrors bundle),-         ErrorCustom contextual <- Set.toList fancy-       ] of-    contextual : _ -> Just contextual-    [] -> Nothing--contextualDiagnostic :: FilePath -> SourceLanguage -> ContextualParseFailure -> SourceLanguageDiagnostic-contextualDiagnostic src sourceLanguage contextual =-  SourceLanguageDiagnostic-    { sourceLanguageErrorCode = code,-      sourceLanguageSource = src,-      sourceLanguageLoc = Loc (contextualFailureLine contextual),-      sourceLanguageToken = case code of-        LanguageFeatureRequiresVersion -> Just (languageVersionText effectiveVersion)-        _ -> Nothing,-      sourceLanguageDeclaredVersion = case code of-        LanguageFeatureRequiresVersion -> Just effectiveVersion-        _ -> Nothing,-      sourceLanguageSupportedVersions = supportedLanguageVersions-    }-  where-    code = contextualFailureCode contextual-    effectiveVersion = effectiveLanguageVersion sourceLanguage--contextualFailureAt :: Loc -> SourceLanguageErrorCode -> P a-contextualFailureAt (Loc line) code = customFailure ContextualParseFailure {contextualFailureCode = code, contextualFailureLine = line}--requireLanguageFeatureAt :: LanguageVersion -> LanguageFeature -> Loc -> P ()-requireLanguageFeatureAt version feature loc-  | languageSupportsFeature version feature = pure ()-  | otherwise = contextualFailureAt loc LanguageFeatureRequiresVersion---- | Consume a preamble already validated by 'selectSourceLanguage'. This--- parser is also reused at grammar boundaries to recognize only complete--- preamble syntax, never a nested identifier whose spelling is @language@.-pDeclaredPreamble :: P ()-pDeclaredPreamble = do-  keyword "language"-  keyword "keiro-dsl"-  _ <- lexeme (some asciiDigit)-  pure ()---- | The source-selection pass inspects only the first grammar clause after--- leading whitespace and comments. Body lines are left entirely to 'pSpec'.-data InitialLanguageClause = InitialLanguageClause-  { initialLanguageLine :: !Int,-    initialLanguageText :: !Text-  }--selectSourceLanguage :: FilePath -> Text -> Either ParseFailure SourceLanguage-selectSourceLanguage src input = do-  initialClause <- case runParser pInitialLanguageClause src input of-    Left bundle -> Left (BodyGrammarFailure (T.pack (errorBundlePretty bundle)))-    Right value -> Right value-  case initialClause of-    Nothing -> Right LegacyUnversioned-    Just languageClause -> do-      version <- parsePreamble languageClause-      case lookupLanguageDefinition version of-        Nothing -> Left (sourceFailure UnsupportedLanguageVersion languageClause (Just (languageVersionText version)) (Just version))-        Just _ -> Right (DeclaredLanguage version (Loc (initialLanguageLine languageClause)))-  where-    sourceFailure code line tokenText declared =-      SourceLanguageFailure-        SourceLanguageDiagnostic-          { sourceLanguageErrorCode = code,-            sourceLanguageSource = src,-            sourceLanguageLoc = Loc (initialLanguageLine line),-            sourceLanguageToken = tokenText,-            sourceLanguageDeclaredVersion = declared,-            sourceLanguageSupportedVersions = supportedLanguageVersions-          }--    parsePreamble line = case T.words (initialLanguageText line) of-      ["language", "keiro-dsl", tokenText]-        | T.all (\c -> isAscii c && isDigit c) tokenText && not (T.null tokenText) ->-            case TR.decimal tokenText :: Either String (Natural, Text) of-              Right (value, "") -> case languageVersion value of-                Just version -> Right version-                Nothing -> invalid line tokenText-              _ -> invalid line tokenText-      wordsFound -> invalid line (T.unwords wordsFound)--    invalid line tokenText =-      Left (sourceFailure InvalidLanguageVersion line (Just tokenText) Nothing)--pInitialLanguageClause :: P (Maybe InitialLanguageClause)-pInitialLanguageClause = sc *> optional pLanguageClause-  where-    pLanguageClause = do-      position <- getSourcePos-      _ <- lookAhead (chunk "language" *> notFollowedBy (identChar <|> (char '-' *> identChar)))-      rawLine <- takeWhileP (Just "language preamble") (\c -> c /= '\n' && c /= '\r')-      let content = T.strip (T.takeWhile (/= '#') rawLine)-      pure InitialLanguageClause {initialLanguageLine = unPos (sourceLine position), initialLanguageText = content}--unsupportedDiagnostic :: FilePath -> SourceLanguage -> ParseFailure-unsupportedDiagnostic src sourceLanguage =-  SourceLanguageFailure-    SourceLanguageDiagnostic-      { sourceLanguageErrorCode = UnsupportedLanguageVersion,-        sourceLanguageSource = src,-        sourceLanguageLoc = case sourceLanguage of-          LegacyUnversioned -> Loc 1-          DeclaredLanguage {languageVersionLoc = loc} -> loc,-        sourceLanguageToken = Just (languageVersionText (effectiveLanguageVersion sourceLanguage)),-        sourceLanguageDeclaredVersion = Just (effectiveLanguageVersion sourceLanguage),-        sourceLanguageSupportedVersions = supportedLanguageVersions-      }------------------------------------------------------------------------------------- Lexer------------------------------------------------------------------------------------- | Space consumer: spaces, newlines, and @#@ line comments are all whitespace.-sc :: P ()-sc = L.space space1 (L.skipLineComment "#") empty--lexeme :: P a -> P a-lexeme = L.lexeme sc--symbol :: Text -> P Text-symbol = L.symbol sc---- | A reserved keyword: the literal word not followed by an identifier--- character (so @goto@ matches @goto@ but not @gotoX@).-keyword :: Text -> P ()-keyword w = (lexeme . try) (string' w *> notFollowedBy (identChar <|> (char '-' *> identChar)))-  where-    string' = chunk--identChar :: P Char-identChar = asciiAlphaNum <|> char '_'--asciiLetter :: P Char-asciiLetter = satisfy (\c -> isAscii c && isAlpha c)--asciiUpper :: P Char-asciiUpper = satisfy (\c -> isAscii c && isUpper c)--asciiDigit :: P Char-asciiDigit = satisfy (\c -> isAscii c && isDigit c)--asciiAlphaNum :: P Char-asciiAlphaNum = satisfy (\c -> isAscii c && isAlphaNum c)---- | Fail with the diagnostic caret placed at a previously captured offset.-failAt :: Int -> String -> P a-failAt offset message = region (setErrorOffset offset) (fail message)---- | Parse a decimal as an unbounded Integer, then reject values that cannot be--- represented as Int. Parsing L.decimal directly at Int silently wraps.-boundedDecimal :: P Int-boundedDecimal = do-  offset <- getOffset-  value <- lexeme (L.decimal :: P Integer)-  checkedDecimal offset value--checkedDecimal :: Int -> Integer -> P Int-checkedDecimal offset value-  | value > fromIntegral (maxBound :: Int) =-      failAt-        offset-        ( "decimal literal "-            <> show value-            <> " is out of range (maximum "-            <> show (maxBound :: Int)-            <> ")"-        )-  | otherwise = pure (fromIntegral value)---- | Words that may not be used as bare identifiers, because they introduce a--- different construct and would otherwise be swallowed (e.g. @aggregate@ ending--- one node and beginning the next).-reservedWords :: [Text]-reservedWords =-  [ "context",-    "module",-    "layout",-    "prefixed",-    "collocated",-    "id",-    "enum",-    "rule",-    "mapped",-    "ex",-    "aggregate",-    "regs",-    "states",-    "command",-    "event",-    "wire",-    "projection",-    "snapshot",-    "category",-    "guard",-    "write",-    "emit",-    "goto",-    "fields",-    "status-map",-    "true",-    "false",-    "retiring",-    "deprecated",-    "upcast",-    "from",-    "HOLE",-    "process",-    "router",-    "dispatch-each",-    "resolve",-    "read-model",-    "dispatch",-    -- EP-4 integration: structural keywords never used as identifiers, so a-    -- list like @accept A B C@ stops at the next block keyword.-    "intake",-    "contract",-    "topic",-    "accept",-    "bind",-    "dedupe",-    "persist",-    "decode",-    "disposition",-    "publisher",-    "map",-    -- EP-5 pgmq structural keywords.-    "workqueue",-    "queue",-    "payload",-    "retry",-    "fanout",-    "dedup",-    "enqueue",-    "seenIn",-    -- EP-6 workflow/operation: reserved so the multi-word result-type parse and-    -- node boundaries don't swallow the next block keyword.-    "workflow",-    "operation",-    "consistency",-    "body",-    "step",-    "await",-    "sleep",-    "child",-    "patch",-    "continueAsNew",-    -- EP-107 read-model structural words. Clause labels such as table and-    -- schema remain usable identifiers because their block parser consumes-    -- them with symbol-style matching.-    "readmodel",-    "columns",-    "feed",-    "scope",-    "shape"-  ]---- | A CamelCase / snake_case identifier (no dashes): type names, register--- names, command\/event\/state names, enum constructors, projection keys.-ident :: P Name-ident = (lexeme . try) $ do-  c <- asciiLetter <|> char '_'-  cs <- many identChar-  let w = T.pack (c : cs)-  if w `elem` reservedWords-    then fail ("unexpected reserved word " <> T.unpack w)-    else pure w---- | A wire-spelling token, which may contain dashes (@partial-divert@,--- @hospital-capacity@). Used for the context name, id prefixes, enum wire--- spellings, and status-map values.-wireWord :: P Text-wireWord = lexeme $ do-  c <- asciiLetter <|> asciiDigit-  cs <- many (identChar <|> char '-')-  pure (T.pack (c : cs))---- | Patch ids use wire-word spelling, but admit @:@ so the validator can emit--- the domain-specific 'WorkflowPatchIdInvalid' diagnostic at the owning item.-patchIdWord :: P Text-patchIdWord = lexeme $ do-  c <- asciiLetter <|> asciiDigit-  cs <- many (identChar <|> char '-' <|> char ':')-  pure (T.pack (c : cs))--getLoc :: P Loc-getLoc = (Loc . unPos . sourceLine) <$> getSourcePos------------------------------------------------------------------------------------- Top level-----------------------------------------------------------------------------------data TopItem-  = TIId IdDecl-  | TIEnum EnumDecl-  | TIRule RuleDecl-  | TINominalScalar NominalScalarDecl-  | TIMapped MappedDecl-  | TINode Node--pContextualPreamble :: SourceLanguageErrorCode -> P a-pContextualPreamble code = do-  loc <- getLoc-  _ <- try pDeclaredPreamble-  contextualFailureAt loc code--pSpec :: LanguageVersion -> SourceLanguageErrorCode -> P Spec-pSpec version laterPreambleCode = do-  pContextualPreamble laterPreambleCode <|> pure ()-  keyword "context"-  ctx <- wireWord-  mroot <- optional pModuleClause-  mlayout <- optional pLayoutClause-  items <- many (pTopItem version laterPreambleCode)-  pure-    Spec-      { specContext = ctx,-        specModuleRoot = mroot,-        specLayout = mlayout,-        specIds = [d | TIId d <- items],-        specEnums = [d | TIEnum d <- items],-        specRules = [d | TIRule d <- items],-        specNominalScalars = [d | TINominalScalar d <- items],-        specMapped = [d | TIMapped d <- items],-        specNodes = [n | TINode n <- items]-      }---- | @module Acme.Services@ — the optional namespace-prefix clause.-pModuleClause :: P Text-pModuleClause = keyword "module" *> pModulePrefix---- | @layout (prefixed|collocated)@ — the optional placement-style clause.-pLayoutClause :: P Placement-pLayoutClause =-  keyword "layout"-    *> choice-      [ GeneratedPrefix <$ keyword "prefixed",-        CollocatedLeaf <$ keyword "collocated"-      ]---- | A dotted module prefix: one-or-more PascalCase segments joined by dots,--- e.g. @Acme@ or @Acme.Services@.-pModulePrefix :: P Text-pModulePrefix = lexeme $ do-  seg0 <- pSeg-  segs <- many (char '.' *> pSeg)-  pure (T.intercalate "." (seg0 : segs))-  where-    pSeg = do-      c <- asciiUpper-      cs <- many identChar-      pure (T.pack (c : cs))--pTopItem :: LanguageVersion -> SourceLanguageErrorCode -> P TopItem-pTopItem version laterPreambleCode =-  choice-    ( [ pContextualPreamble laterPreambleCode,-        TIId <$> pIdDecl version,-        TIEnum <$> pEnumDecl version,-        TIRule <$> pRuleDecl version,-        pMappedTopItem version-      ]-        ++ [ TINode . NRouter <$> pRouter,-             TINode . NProcess <$> pProcess,-             TINode . NContract <$> pContract,-             TINode . NIntake <$> pIntake,-             TINode . NEmit <$> pEmit,-             TINode . NPublisher <$> pPublisher,-             TINode . NWorkqueue <$> pWorkqueue,-             TINode . NPgmqDispatch <$> pPgmqDispatch,-             TINode . NReadModel <$> pReadModel,-             TINode . NWorkflow <$> pWorkflow,-             TINode . NOperation <$> pOperation,-             TINode . NAggregate <$> pAggregate version-           ]-    )--pIdDecl :: LanguageVersion -> P IdDecl-pIdDecl version = do-  loc <- getLoc-  keyword "id"-  name <- ident-  _ <- symbol "prefix"-  _ <- symbol "="-  pfx <- wireWord-  binding <- optionalLanguageFeature version NominalBindingSyntax "using" pUsingNominalBinding-  pure IdDecl {idName = name, idPrefix = pfx, idBinding = binding, idLoc = loc}--pEnumDecl :: LanguageVersion -> P EnumDecl-pEnumDecl version = do-  loc <- getLoc-  keyword "enum"-  name <- ident-  ctors <- braces (many pEnumCtor)-  binding <- optionalLanguageFeature version NominalBindingSyntax "using" pUsingNominalBinding-  pure EnumDecl {enumName = name, enumCtors = ctors, enumBinding = binding, enumLoc = loc}-  where-    pEnumCtor = do-      c <- ident-      _ <- symbol "="-      w <- wireWord-      pure (c, w)--pRuleDecl :: LanguageVersion -> P RuleDecl-pRuleDecl version = do-  loc <- getLoc-  keyword "rule"-  name <- ident-  _ <- symbol ":"-  dom <- ident-  _ <- symbol "->"-  cod <- ident-  keyword "ex"-  cases <- sepBy1 pCase (symbol ";")-  pure-    RuleDecl-      { ruleName = name,-        ruleDomain = dom,-        ruleCodomain = cod,-        ruleCases = cases,-        ruleLoc = loc-      }-  where-    pCase = do-      c <- ident-      _ <- symbol "=>"-      e <- pExpr version-      pure (c, e)--optionalLanguageFeature :: LanguageVersion -> LanguageFeature -> Text -> P a -> P (Maybe a)-optionalLanguageFeature version feature marker parser-  | languageSupportsFeature version feature = optional parser-  | otherwise = reject <|> pure Nothing-  where-    reject = do-      loc <- getLoc-      _ <- try (keyword marker)-      contextualFailureAt loc LanguageFeatureRequiresVersion------------------------------------------------------------------------------------- Consumer-owned mapped and nominal types-----------------------------------------------------------------------------------data MappedKind = MappedRecord | MappedEnum | MappedUnion--data MappedClause-  = MCHaskell HaskellSource-  | MCBinding Text-  | MCBindingVersion Text-  | MCCanonical Text-  | MCFixtures Text-  | MCInitial Text-  | MCCodec Text-  | MCCodecVersion Text-  | MCShape MappedShape--pMappedTopItem :: LanguageVersion -> P TopItem-pMappedTopItem version = do-  loc <- getLoc-  keyword "mapped"-  choice-    [ if languageSupportsFeature version NominalBindingSyntax-        then TINominalScalar <$> pNominalScalarAfterMapped loc-        else do-          _ <- try (keyword "nominal")-          contextualFailureAt loc LanguageFeatureRequiresVersion,-      TIMapped <$> pMappedStructural version loc,-      TIMapped <$> pMappedOpaque loc-    ]--pMappedStructural :: LanguageVersion -> Loc -> P MappedDecl-pMappedStructural version loc = do-  keyword "structural"-  kind <--    choice-      [ MappedRecord <$ keyword "record",-        MappedEnum <$ keyword "enum",-        MappedUnion <$ keyword "union"-      ]-  name <- ident-  clauses <- braces (many (pStructuralClause version kind))-  hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses-  binding <- oneClause "binding" (\case MCBinding value -> Just value; _ -> Nothing) clauses-  bindingVersion <- oneClause "binding-version" (\case MCBindingVersion value -> Just value; _ -> Nothing) clauses-  canonical <- oneClause "canonical-type" (\case MCCanonical value -> Just value; _ -> Nothing) clauses-  fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses-  initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses-  shape <- requiredClause "wire" (\case MCShape value -> Just value; _ -> Nothing) clauses-  pure-    MappedStructural-      { msName = name,-        msHaskell = hs,-        msBinding = binding,-        msBindingVersion = bindingVersion,-        msCanonical = canonical,-        msFixtures = fixtures,-        msInitial = initial,-        msShape = shape,-        msLoc = loc-      }--pMappedOpaque :: Loc -> P MappedDecl-pMappedOpaque loc = do-  keyword "opaque"-  name <- ident-  clauses <- braces (many pOpaqueClause)-  hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses-  codec <- oneClause "codec" (\case MCCodec value -> Just value; _ -> Nothing) clauses-  version <- oneClause "version" (\case MCCodecVersion value -> Just value; _ -> Nothing) clauses-  fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses-  initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses-  pure-    MappedOpaque-      { moName = name,-        moHaskell = hs,-        moCodecId = codec,-        moCodecVersion = version,-        moFixtures = fixtures,-        moInitial = initial,-        moLoc = loc-      }--pNominalScalarAfterMapped :: Loc -> P NominalScalarDecl-pNominalScalarAfterMapped loc = do-  keyword "nominal"-  name <- ident-  _ <- symbol ":"-  representation <- ident-  binding <- pNominalBindingBlock loc-  pure-    NominalScalarDecl-      { nominalScalarName = name,-        nominalScalarRepresentation = representation,-        nominalScalarBinding = binding,-        nominalScalarLoc = loc-      }--pUsingNominalBinding :: P NominalBindingDecl-pUsingNominalBinding = do-  keyword "using"-  loc <- getLoc-  pNominalBindingBlock loc--pNominalBindingBlock :: Loc -> P NominalBindingDecl-pNominalBindingBlock loc = do-  clauses <- braces (many pNominalClause)-  hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses-  binding <- oneClause "binding" (\case MCBinding value -> Just value; _ -> Nothing) clauses-  bindingVersion <- oneClause "binding-version" (\case MCBindingVersion value -> Just value; _ -> Nothing) clauses-  canonical <- oneClause "canonical-type" (\case MCCanonical value -> Just value; _ -> Nothing) clauses-  fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses-  initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses-  pure-    NominalBindingDecl-      { nominalHaskell = hs,-        nominalBinding = binding,-        nominalBindingVersion = bindingVersion,-        nominalCanonicalType = canonical,-        nominalFixtures = fixtures,-        nominalInitial = initial,-        nominalLoc = loc-      }--pNominalClause :: P MappedClause-pNominalClause =-  choice-    [ MCHaskell <$> pHaskellSource,-      MCBindingVersion <$> pQuotedFact "binding-version",-      MCBinding <$> pQuotedFact "binding",-      MCCanonical <$> pQuotedFact "canonical-type",-      MCFixtures <$> pQuotedFact "fixtures",-      MCInitial <$> pQuotedFact "initial"-    ]--pStructuralClause :: LanguageVersion -> MappedKind -> P MappedClause-pStructuralClause version kind =-  choice-    [ MCHaskell <$> pHaskellSource,-      MCBindingVersion <$> pQuotedFact "binding-version",-      MCBinding <$> pQuotedFact "binding",-      MCCanonical <$> pQuotedFact "canonical-type",-      MCFixtures <$> pQuotedFact "fixtures",-      MCInitial <$> pQuotedFact "initial",-      MCShape <$> pMappedShape version kind-    ]--pOpaqueClause :: P MappedClause-pOpaqueClause =-  choice-    [ MCHaskell <$> pHaskellSource,-      MCCodec <$> pQuotedFact "codec",-      MCCodecVersion <$> pQuotedFact "version",-      MCFixtures <$> pQuotedFact "fixtures",-      MCInitial <$> pQuotedFact "initial"-    ]--pHaskellSource :: P HaskellSource-pHaskellSource = do-  keyword "haskell"-  keyword "package"-  _ <- symbol "="-  packageName <- wireWord-  keyword "module"-  _ <- symbol "="-  moduleName <- pModulePrefix-  keyword "type"-  _ <- symbol "="-  typeName <- ident-  pure HaskellSource {hsPackage = packageName, hsModule = moduleName, hsType = typeName}--pQuotedFact :: Text -> P Text-pQuotedFact factName = keyword factName *> symbol "=" *> stringLit--pMappedShape :: LanguageVersion -> MappedKind -> P MappedShape-pMappedShape version kind = do-  keyword "wire"-  case kind of-    MappedRecord -> do-      keyword "object"-      keyword "constructor"-      _ <- symbol "="-      constructor <- ident-      unknownFields <- pUnknownFieldsFact-      fields <- braces (many (pWireField version))-      pure (ShapeRecord constructor unknownFields fields)-    MappedEnum -> do-      keyword "string"-      ShapeEnum <$> braces (many pWireEnum)-    MappedUnion -> do-      keyword "tagged-object"-      keyword "tag"-      _ <- symbol "="-      tagField <- stringLit-      keyword "contents"-      _ <- symbol "="-      contentsField <- stringLit-      unknownFields <- pUnknownFieldsFact-      arms <- braces (many (pWireArm version))-      pure (ShapeUnion (TaggedObject tagField contentsField unknownFields) arms)--pUnknownFieldsFact :: P UnknownFields-pUnknownFieldsFact = do-  keyword "unknown-fields"-  _ <- symbol "="-  choice [RejectUnknown <$ keyword "reject", IgnoreUnknown <$ keyword "ignore"]--pWireField :: LanguageVersion -> P WireField-pWireField version = do-  loc <- getLoc-  haskellName <- ident-  keyword "as"-  wireKey <- stringLit-  _ <- symbol ":"-  fieldType <- pMappedTypeExpr version-  presence <- choice [PRequired <$ keyword "required", POptional <$ keyword "optional"]-  onMissing <- optional (keyword "on-missing" *> symbol "=" *> pOnMissing)-  pure-    WireField-      { wfHaskell = haskellName,-        wfKey = wireKey,-        wfType = fieldType,-        wfPresence = presence,-        wfOnMissing = onMissing,-        wfLoc = loc-      }--pWireEnum :: P WireEnum-pWireEnum = do-  loc <- getLoc-  constructor <- ident-  keyword "as"-  wireTag <- stringLit-  pure WireEnum {weCtor = constructor, weTag = wireTag, weLoc = loc}--pWireArm :: LanguageVersion -> P WireArm-pWireArm version = do-  loc <- getLoc-  constructor <- ident-  keyword "as"-  wireTag <- stringLit-  payload <- optional (symbol ":" *> pMappedTypeExpr version)-  pure WireArm {waCtor = constructor, waTag = wireTag, waPayload = payload, waLoc = loc}--pMappedTypeExpr :: LanguageVersion -> P TypeExpr-pMappedTypeExpr version =-  choice-    [ TOptional <$> (keyword "Optional" *> pTypeArgument),-      TList <$> (keyword "List" *> pTypeArgument),-      TMap <$> (keyword "Map" *> pTypeArgument),-      TText <$ keyword "Text",-      TInt <$ keyword "Int",-      TInteger <$ languageFeatureKeyword version IntegerScalarSyntax "Integer",-      TBool <$ keyword "Bool",-      TNatural <$ keyword "Natural",-      TTime <$ (keyword "Time" <|> keyword "UTCTime"),-      TJson <$ keyword "Json",-      TRef <$> ident-    ]-  where-    pTypeArgument = parens (pMappedTypeExpr version) <|> pTypeAtom-    pTypeAtom =-      choice-        [ TText <$ keyword "Text",-          TInt <$ keyword "Int",-          TInteger <$ languageFeatureKeyword version IntegerScalarSyntax "Integer",-          TBool <$ keyword "Bool",-          TNatural <$ keyword "Natural",-          TTime <$ (keyword "Time" <|> keyword "UTCTime"),-          TJson <$ keyword "Json",-          TRef <$> ident-        ]--languageFeatureKeyword :: LanguageVersion -> LanguageFeature -> Text -> P ()-languageFeatureKeyword version feature spelling = do-  loc <- getLoc-  keyword spelling-  requireLanguageFeatureAt version feature loc--pOnMissing :: P OnMissing-pOnMissing =-  choice-    [ OmNull <$ keyword "null",-      OmEmptyList <$ (symbol "[" *> symbol "]"),-      OmEmptyMap <$ (symbol "{" *> symbol "}"),-      OmBool True <$ keyword "true",-      OmBool False <$ keyword "false",-      OmText <$> stringLit,-      OmInt <$> integerLiteral,-      OmCtor <$> ident-    ]--integerLiteral :: P Integer-integerLiteral = lexeme (L.signed (pure ()) L.decimal)--oneClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P (Maybe a)-oneClause clauseName select clauses =-  case mapMaybe select clauses of-    [] -> pure Nothing-    [value] -> pure (Just value)-    _ -> fail ("duplicate " <> clauseName <> " clause in mapped declaration")--requiredClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P a-requiredClause clauseName select clauses = do-  found <- oneClause clauseName select clauses-  maybe (fail ("missing " <> clauseName <> " clause in mapped structural declaration")) pure found------------------------------------------------------------------------------------- Aggregate node-----------------------------------------------------------------------------------data BodyItem-  = BICommand Command-  | BIEvent Event-  | BIWire WireSpec-  | BIProjection ProjectionSpec-  | BISnapshot SnapshotSpec-  | BITransition Transition--pAggregate :: LanguageVersion -> P Aggregate-pAggregate version = do-  loc <- getLoc-  keyword "aggregate"-  name <- ident-  regs <- pRegsBlock version-  states <- pStatesLine-  positionedItems <- many ((,) <$> getOffset <*> pBodyItem version)-  let items = map snd positionedItems-      wireOffsets = [offset | (offset, BIWire _) <- positionedItems]-      projectionOffsets = [offset | (offset, BIProjection _) <- positionedItems]-      snapshotOffsets = [offset | (offset, BISnapshot _) <- positionedItems]-  case wireOffsets of-    _ : duplicateOffset : _ ->-      failAt duplicateOffset ("duplicate wire block in aggregate " <> T.unpack name <> " (only one is allowed)")-    _ -> pure ()-  case projectionOffsets of-    _ : duplicateOffset : _ ->-      failAt duplicateOffset ("duplicate projection block in aggregate " <> T.unpack name <> " (only one is allowed)")-    _ -> pure ()-  case snapshotOffsets of-    _ : duplicateOffset : _ ->-      failAt duplicateOffset ("duplicate snapshot block in aggregate " <> T.unpack name <> " (only one is allowed)")-    _ -> pure ()-  pure-    Aggregate-      { aggName = name,-        aggRegs = regs,-        aggStates = states,-        aggCommands = [c | BICommand c <- items],-        aggEvents = [e | BIEvent e <- items],-        aggTransitions = [t | BITransition t <- items],-        aggWire = listToMaybe [w | BIWire w <- items],-        aggProjection = listToMaybe [p | BIProjection p <- items],-        aggSnapshot = listToMaybe [s | BISnapshot s <- items],-        aggLoc = loc-      }-  where-    listToMaybe xs = case xs of (x : _) -> Just x; [] -> Nothing--pRegsBlock :: LanguageVersion -> P [RegDecl]-pRegsBlock version = do-  keyword "regs"-  many (pRegDecl version)--pRegDecl :: LanguageVersion -> P RegDecl-pRegDecl version = do-  loc <- getLoc-  name <- ident-  ty <- pMappedTypeExpr version-  _ <- symbol "="-  initial <- (RegInitText <$> stringLit) <|> (RegInitBare <$> (ident <|> signedDecimalText))-  pure RegDecl {regName = name, regType = ty, regInitial = initial, regLoc = loc}--pStatesLine :: P [StateDecl]-pStatesLine = do-  keyword "states"-  many pStateDecl-  where-    -- A state decl is an identifier with an optional terminal @!@. The-    -- @notFollowedBy@ lookahead stops the list before a transition whose source-    -- state would otherwise be swallowed as an extra state, e.g. when a-    -- transition directly follows the @states@ line with no command\/event-    -- between them. The @try@ backtracks so the identifier is left for-    -- 'pTransition'.-    pStateDecl = try $ do-      loc <- getLoc-      -- A @replay-only@ transition marker directly after the states line-      -- must not be swallowed: 'ident' would take @replay@ (hyphens are-      -- not identifier characters) and strand @-only@.-      notFollowedBy (keyword "replay-only")-      n <- ident-      term <- option False (True <$ symbol "!")-      notFollowedBy (symbol "--")-      pure StateDecl {stName = n, stTerminal = term, stLoc = loc}--pBodyItem :: LanguageVersion -> P BodyItem-pBodyItem version =-  choice-    [ BICommand <$> pCommand version,-      BIEvent <$> pEvent version,-      BIWire <$> pWire,-      BIProjection <$> pProjection,-      BISnapshot <$> pSnapshot,-      BITransition <$> pTransition version-    ]--pSnapshot :: P SnapshotSpec-pSnapshot = do-  loc <- getLoc-  keyword "snapshot"-  policy <--    choice-      [ SnapEvery <$> (keyword "every" *> boundedDecimal),-        SnapOnTerminal <$ symbol "on-terminal"-      ]-  _ <- symbol "state-codec"-  _ <- symbol "version" *> symbol "="-  version <- boundedDecimal-  _ <- symbol "shape-hash" *> symbol "="-  hash <- stringLit-  pure SnapshotSpec {snapPolicy = policy, snapCodecVersion = version, snapShapeHash = hash, snapLoc = loc}--pCommand :: LanguageVersion -> P Command-pCommand version = do-  loc <- getLoc-  keyword "command"-  name <- ident-  fs <- braces (many (pAggregateField version))-  pure Command {cmdName = name, cmdFields = fs, cmdLoc = loc}--pAggregateField :: LanguageVersion -> P AggregateField-pAggregateField version = do-  loc <- getLoc-  n <- ident-  mty <- optional (symbol ":" *> pMappedTypeExpr version)-  pure AggregateField {aggregateFieldName = n, aggregateFieldType = mty, aggregateFieldLoc = loc}--pField :: P Field-pField = do-  n <- ident-  mty <- optional (symbol ":" *> ident)-  pure Field {fieldName = n, fieldType = mty}--pEvent :: LanguageVersion -> P Event-pEvent version = do-  loc <- getLoc-  (retiring, deprecated) <--    option-      (False, False)-      ( choice-          [ (True, False) <$ keyword "retiring",-            (False, True) <$ keyword "deprecated"-          ]-      )-  keyword "event"-  name <- ident-  ver <- option 1 pVersion-  body <--    choice-      [ EventFromCommand <$> (symbol "=" *> keyword "fields" *> parens ident),-        EventFields <$> braces (many (pAggregateField version))-      ]-  up <- optional pUpcast-  pure-    Event-      { evName = name,-        evBody = body,-        evVersion = ver,-        evUpcastFrom = up,-        evRetiring = retiring,-        evDeprecated = deprecated,-        evLoc = loc-      }-  where-    pUpcast = do-      keyword "upcast"-      keyword "from"-      m <- pVersion-      _ <- symbol "="-      keyword "HOLE"-      pure (m, Hole)---- | A @vN@ schema-version token (e.g. @v2@). Fails (backtracking) on anything--- that is not @v@ immediately followed by digits.-pVersion :: P Int-pVersion = do-  offset <- getOffset-  value <- lexeme (try (char 'v' *> (L.decimal :: P Integer) <* notFollowedBy identChar))-  checkedDecimal offset value--pWire :: P WireSpec-pWire = do-  keyword "wire"-  _ <- symbol "kind"-  _ <- symbol "="-  k <- wireWord-  _ <- symbol "fields"-  _ <- symbol "="-  f <- wireWord-  _ <- symbol "schemaVersion"-  _ <- symbol "="-  v <- boundedDecimal-  pure WireSpec {wireKind = k, wireFields = f, wireSchemaVersion = v}--pProjection :: P ProjectionSpec-pProjection = do-  loc <- getLoc-  keyword "projection"-  table <- ident-  cons <- optional (symbol "consistency" *> symbol "=" *> pConsistency)-  _ <- symbol "key"-  _ <- symbol "="-  k <- ident-  sm <- optional pStatusMap-  pure-    ProjectionSpec-      { projTable = table,-        projConsistency = cons,-        projKey = k,-        projStatusMap = sm,-        projLoc = loc-      }-  where-    pConsistency =-      choice [Strong <$ keyword "Strong", Eventual <$ keyword "Eventual"]--pStatusMap :: P Mapping-pStatusMap = do-  keyword "status-map"-  partial <- option False (True <$ keyword "partial")-  pairs <- braces (many pPair)-  pure Mapping {mapPairs = pairs, mapPartial = partial}-  where-    pPair = do-      l <- ident-      _ <- symbol "=>"-      r <- wireWord-      pure (l, r)------------------------------------------------------------------------------------- Integration contract (EP-4)-----------------------------------------------------------------------------------pContract :: P ContractNode-pContract = do-  loc <- getLoc-  keyword "contract"-  nm <- ident-  _ <- symbol "{"-  keyword "schemaVersion"-  sv <- boundedDecimal-  keyword "discriminator"-  disc <- ident-  topics <- many pTopic-  events <- many pContractEvent-  _ <- symbol "}"-  pure-    ContractNode-      { ctrName = nm,-        ctrSchemaVersion = sv,-        ctrDiscriminator = disc,-        ctrTopics = topics,-        ctrEvents = events,-        ctrLoc = loc-      }-  where-    pTopic = do-      keyword "topic"-      alias <- ident-      t <- stringLit-      pure (alias, t)-    pContractEvent = do-      keyword "event"-      nm <- ident-      keyword "on"-      topicAlias <- ident-      fs <- braces (many pContractField)-      pure ContractEvent {ceName = nm, ceTopic = topicAlias, ceFields = fs}-    pContractField = do-      n <- ident-      _ <- symbol ":"-      ty <- pContractType-      _ <- optional (symbol ";")-      pure ContractField {cfName = n, cfType = ty}-    pContractType =-      choice-        [ CTypeId <$> (keyword "typeid" *> stringLit),-          CText <$ keyword "text",-          CInt <$ keyword "int"-        ]--pIntake :: P IntakeNode-pIntake = do-  loc <- getLoc-  keyword "intake"-  nm <- ident-  _ <- symbol "{"-  keyword "contract"-  ctr <- ident-  keyword "topic"-  tp <- ident-  keyword "accept"-  acc <- some ident-  binds <- many pBindRow-  keyword "dedupe"-  keyword "key"-  dk <- ident-  keyword "policy"-  dp <- ident-  persistence <--    option InkPersistFull $-      keyword "persist"-        *> symbol "="-        *> choice-          [ InkPersistFull <$ keyword "full-envelope",-            InkPersistDedupeOnly <$ keyword "dedupe-only"-          ]-  dec <- pDecode-  disp <- pDisposition-  _ <- symbol "}"-  pure-    IntakeNode-      { inkName = nm,-        inkContract = ctr,-        inkTopic = tp,-        inkAccept = acc,-        inkBinds = binds,-        inkDedupeKey = dk,-        inkDedupePolicy = dp,-        inkPersist = persistence,-        inkDecode = dec,-        inkDisposition = disp,-        inkLoc = loc-      }-  where-    pBindRow = do-      keyword "bind"-      f <- ident-      keyword "from"-      src <- pWireSource-      req <- option False (True <$ keyword "required")-      xc <- option False (True <$ (keyword "cross-check" *> keyword "body"))-      pure BindRow {brField = f, brSource = src, brRequired = req, brCrossCheck = xc}-    pWireSource =-      choice-        [ SrcHeader <$> (keyword "header" *> stringLit),-          SrcKafkaKey <$ keyword "kafka-key",-          SrcKafkaCursor <$ keyword "kafka-cursor",-          SrcBody <$ keyword "body"-        ]-    pDecode = do-      keyword "decode"-      _ <- symbol "{"-      keyword "envelope"-      env <- pEnvelopePolicy-      keyword "body"-      strict <- (True <$ keyword "strict") <|> (False <$ keyword "lenient")-      keyword "schemaVersion"-      _ <- symbol "=="-      v <- boundedDecimal-      _ <- symbol "}"-      pure DecodeSpec {decEnvelope = env, decBodyStrict = strict, decBodySchemaVersion = v}-    pEnvelopePolicy = do-      a <- wireWord-      b <- wireWord-      pure (a <> " " <> b)-    pDisposition = do-      keyword "disposition"-      rows <- braces (many pDispositionRow)-      pure rows-    pDispositionRow = do-      loc <- getLoc-      o <- ident-      _ <- symbol "=>"-      act <- pInboxAction-      pure DispositionRow {drOutcome = o, drAction = act, drLoc = loc}-    pInboxAction =-      choice-        [ IAckOk <$ keyword "ackOk",-          IRetry <$> (keyword "retry" *> pWindow),-          IDeadLetter <$> (keyword "deadLetter" *> optional stringLit)-        ]--pEmit :: P EmitNode-pEmit = do-  loc <- getLoc-  keyword "emit"-  nm <- ident-  _ <- symbol "{"-  keyword "contract"-  ctr <- ident-  keyword "topic"-  tp <- ident-  keyword "source"-  src <- stringLit-  keyword "key"-  k <- ident-  keyword "map"-  disc <- ident-  (rows, skip) <- braces pMapRows-  keyword "messageId"-  mid <- pDerive-  keyword "idempotencyKey"-  idk <- pDerive-  _ <- symbol "}"-  pure-    EmitNode-      { emName = nm,-        emContract = ctr,-        emTopic = tp,-        emSource = src,-        emKey = k,-        emDiscriminant = disc,-        emMap = rows,-        emSkip = skip,-        emMessageId = mid,-        emIdempotencyKey = idk,-        emLoc = loc-      }-  where-    pMapRows = do-      rows <- many pMapRow-      skip <- option False (True <$ try (symbol "_" *> symbol "=>" *> keyword "skip"))-      pure (rows, skip)-    pMapRow = try $ do-      loc <- getLoc-      v <- stringLit-      _ <- symbol "=>"-      ev <- ident-      pure EmitMapRow {emrValue = v, emrEvent = ev, emrLoc = loc}-    pDerive = do-      keyword "derive"-      pfx <- optional stringLit-      keyword "hole"-      pure DeriveSpec {dsPrefix = pfx}--pPublisher :: P PublisherNode-pPublisher = do-  loc <- getLoc-  keyword "publisher"-  nm <- ident-  _ <- symbol "{"-  keyword "emit"-  em <- ident-  keyword "ordering"-  ord <- ident-  keyword "maxAttempts"-  ma <- boundedDecimal-  keyword "backoff"-  bk <- ident-  bw <- pWindow-  bm <- optional (keyword "max" *> symbol "=" *> pWindow)-  multiplier <- optional (keyword "multiplier" *> symbol "=" *> decimalText)-  keyword "outboxId"-  keyword "stable"-  keyword "from"-  obf <- ident-  _ <- symbol "}"-  pure-    PublisherNode-      { pubName = nm,-        pubEmit = em,-        pubOrdering = ord,-        pubMaxAttempts = ma,-        pubBackoff = BackoffSpec {boKind = bk, boWindow = bw, boMax = bm, boMultiplier = multiplier},-        pubOutboxField = obf,-        pubLoc = loc-      }--pWorkqueue :: P WorkqueueNode-pWorkqueue = do-  loc <- getLoc-  keyword "workqueue"-  nm <- ident-  _ <- symbol "{"-  keyword "queue"-  _ <- symbol "logical" *> symbol "="-  logical <- stringLit-  keyword "derive"-  _ <- symbol "physical" *> symbol "="-  phys <- stringLit-  _ <- symbol "dlq" *> symbol "="-  dlqName <- stringLit-  _ <- symbol "table" *> symbol "="-  tbl <- stringLit-  ordering <- option WqUnordered pOrdering-  groupKey <- optional pGroupKey-  provision <- option WqStandard pProvision-  keyword "payload"-  pn <- ident-  fields <- braces (many pWqField)-  keyword "retry"-  _ <- symbol "maxRetries" *> symbol "="-  mr <- boundedDecimal-  _ <- symbol "delay" *> symbol "="-  dl <- pWindow-  _ <- symbol "dlq" *> symbol "="-  dlqOn <- (True <$ keyword "on") <|> (False <$ keyword "off")-  keyword "disposition"-  disp <- braces (many pWqDispRow)-  _ <- symbol "}"-  pure-    WorkqueueNode-      { wqName = nm,-        wqLogical = logical,-        wqPhysical = phys,-        wqDlq = dlqName,-        wqTable = tbl,-        wqOrdering = ordering,-        wqGroupKey = groupKey,-        wqProvision = provision,-        wqPayloadName = pn,-        wqPayload = fields,-        wqMaxRetries = mr,-        wqDelay = dl,-        wqDlqOn = dlqOn,-        wqDisposition = disp,-        wqLoc = loc-      }-  where-    pOrdering = do-      _ <- symbol "ordering"-      choice-        [ WqUnordered <$ symbol "unordered",-          WqFifoThroughput <$ symbol "fifo-throughput",-          WqFifoRoundRobin <$ symbol "fifo-roundrobin"-        ]-    pGroupKey = do-      _ <- symbol "group" *> symbol "key" *> symbol "from"-      field <- ident-      _ <- symbol "via"-      via <- ident-      fixture <- optional (symbol "fixture" *> stringLit)-      pure WqGroupKey {gkField = field, gkVia = via, gkFixture = fixture}-    pProvision = do-      _ <- symbol "provision"-      choice-        [ WqStandard <$ symbol "standard",-          WqUnlogged <$ symbol "unlogged",-          do-            _ <- symbol "partitioned" *> symbol "("-            _ <- symbol "interval" *> symbol "="-            interval <- stringLit-            _ <- symbol "," *> symbol "retention" *> symbol "="-            retention <- stringLit-            _ <- symbol ")"-            pure (WqPartitioned interval retention)-        ]-    pWqField = do-      n <- ident-      _ <- symbol "->"-      w <- stringLit-      ty <- ident-      req <- option False (True <$ keyword "required")-      pure WqField {wqfName = n, wqfWire = w, wqfType = ty, wqfRequired = req}-    pWqDispRow = do-      loc <- getLoc-      o <- ident-      _ <- symbol "->"-      act <- choice [IAckOk <$ keyword "ackOk", IRetry <$> (keyword "retry" *> pWindow), IDeadLetter <$> (keyword "deadLetter" *> optional stringLit)]-      pure WqDispRow {wqdOutcome = o, wqdAction = act, wqdLoc = loc}--pReadModel :: P ReadModelNode-pReadModel = do-  loc <- getLoc-  keyword "readmodel"-  name <- ident-  _ <- symbol "{"-  _ <- symbol "table" *> symbol "="-  table <- stringLit-  _ <- symbol "schema" *> symbol "="-  schema <- stringLit-  _ <- symbol "columns"-  columns <- braces (many pColumn)-  _ <- symbol "version" *> symbol "="-  version <- boundedDecimal-  _ <- symbol "shape" *> symbol "="-  shape <- stringLit-  _ <- symbol "consistency" *> symbol "="-  consistency <- pConsistency-  scope <- optional (symbol "scope" *> symbol "=" *> pScope)-  _ <- symbol "feed" *> symbol "="-  feed <- pFeed-  subscription <- optional (symbol "subscription" *> symbol "=" *> stringLit)-  _ <- symbol "}"-  pure-    ReadModelNode-      { rmName = name,-        rmTable = table,-        rmSchema = schema,-        rmColumns = columns,-        rmVersion = version,-        rmShape = shape,-        rmConsistency = consistency,-        rmScope = scope,-        rmFeed = feed,-        rmSubscription = subscription,-        rmLoc = loc-      }-  where-    pColumn =-      RmColumn-        <$> wireWord-        <*> ident-        <*> option False (True <$ keyword "required")-    pConsistency = choice [Strong <$ keyword "Strong", Eventual <$ keyword "Eventual"]-    pScope =-      choice-        [ RmEntireLog <$ keyword "entire-log",-          RmCategory <$> (keyword "category" *> stringLit)-        ]-    pFeed = choice [RmInline <$ keyword "inline", RmSubscription <$ keyword "subscription"]--pPgmqDispatch :: P PgmqDispatchNode-pPgmqDispatch = do-  loc <- getLoc-  keyword "dispatch"-  nm <- ident-  _ <- symbol "{"-  keyword "source"-  _ <- symbol "readModel" *> symbol "="-  srm <- ident-  _ <- symbol "key" *> symbol "="-  sk <- ident-  keyword "fanout"-  _ <- symbol "body" *> symbol "="-  fb <- ident-  keyword "dedup"-  _ <- symbol "key" *> symbol "="-  dk <- ident-  _ <- keyword "seenIn" *> symbol "readModel" *> symbol "="-  drm <- ident-  _ <- symbol "field" *> symbol "="-  drmf <- ident-  _ <- keyword "seenIn" *> symbol "queue" *> symbol "="-  dq <- ident-  _ <- symbol "field" *> symbol "="-  dqf <- ident-  keyword "enqueue"-  _ <- symbol "to" *> symbol "="-  enq <- ident-  _ <- symbol "}"-  pure-    PgmqDispatchNode-      { pdName = nm,-        pdSourceReadModel = srm,-        pdSourceKey = sk,-        pdFanoutBody = fb,-        pdDedupKey = dk,-        pdDedupReadModel = drm,-        pdDedupReadModelField = drmf,-        pdDedupQueue = dq,-        pdDedupQueueField = dqf,-        pdEnqueueTo = enq,-        pdLoc = loc-      }--pWorkflow :: P WorkflowNode-pWorkflow = do-  loc <- getLoc-  keyword "workflow"-  wid <- ident-  keyword "name"-  nm <- stringLit-  keyword "in"-  inTy <- ident-  inFields <- option [] (braces (many pField))-  keyword "out"-  outTy <- ident-  keyword "id"-  keyword "from"-  keyword "input"-  idField <- optional (symbol "." *> ident)-  keyword "via"-  idVia <- ident-  keyword "body"-  body <- many pWfBodyItem-  pure-    WorkflowNode-      { wfId = wid,-        wfStable = nm,-        wfInput = inTy,-        wfInputFields = inFields,-        wfOutput = outTy,-        wfIdField = idField,-        wfIdVia = idVia,-        wfBody = body,-        wfLoc = loc-      }-  where-    pWfBodyItem =-      choice-        [ do-            loc <- getLoc-            WfStep <$> (keyword "step" *> wireWord) <*> (symbol "->" *> ident) <*> pure loc,-          do-            loc <- getLoc-            WfAwait <$> (keyword "await" *> wireWord) <*> (symbol "->" *> ident) <*> pure loc,-          do-            loc <- getLoc-            WfSleep <$> (keyword "sleep" *> wireWord) <*> (keyword "after" *> ident) <*> pure loc,-          do-            loc <- getLoc-            WfChild-              <$> (keyword "child" *> wireWord)-              <*> (keyword "id" *> keyword "input" *> keyword "via" *> ident)-              <*> (symbol "->" *> ident)-              <*> pure loc,-          do-            loc <- getLoc-            WfPatch-              <$> (keyword "patch" *> patchIdWord)-              <*> braces (many pWfBodyItem)-              <*> pure loc,-          do-            loc <- getLoc-            WfContinueAsNew <$> (keyword "continueAsNew" *> ident) <*> pure loc-        ]--pOperation :: P OperationNode-pOperation = do-  loc <- getLoc-  keyword "operation"-  nm <- ident-  shape <--    choice-      [ pCommandOp,-        pQueryOp,-        pSignalOp,-        pRunOp-      ]-  pure OperationNode {opName = nm, opShape = shape, opLoc = loc}-  where-    pCommandOp = do-      keyword "command"-      keyword "on"-      agg <- ident-      _ <- keyword "stream" *> keyword "from"-      sf <- ident-      keyword "via"-      sv <- ident-      proj <- option [] (keyword "project" *> brackets (many ident))-      pure (CommandOp agg sf sv proj)-    pQueryOp = do-      keyword "query"-      rm <- ident-      keyword "input"-      inp <- ident-      keyword "result"-      res <- pTypeExpr-      cons <- option "Strong" (keyword "consistency" *> ident)-      pure (QueryOp rm inp res cons)-    pSignalOp = do-      keyword "signal"-      lbl <- wireWord-      keyword "of"-      wf <- ident-      _ <- keyword "key" *> keyword "from"-      kf <- ident-      keyword "via"-      kv <- ident-      keyword "value"-      val <- ident-      pure (SignalOp lbl wf kf kv val)-    pRunOp = do-      keyword "run"-      wf <- ident-      keyword "input"-      inp <- ident-      _ <- keyword "outcome" *> symbol "->"-      oc <- ident-      pure (RunOp wf inp oc)-    -- A result type expression, possibly multi-word like @Maybe TransferDecision@.-    pTypeExpr = do-      ws <- some ident-      pure (T.unwords ws)------------------------------------------------------------------------------------- Process manager + durable timer (EP-3)-----------------------------------------------------------------------------------pProcess :: P ProcessNode-pProcess = do-  loc <- getLoc-  keyword "process"-  pid <- ident-  keyword "name"-  nm <- stringLit-  inp <- pInputDecl-  corr <- pCorrelate-  saga <- pSaga-  keyword "target"-  tgt <- ident-  projs <- keyword "projections" *> brackets (many ident)-  handle <- pHandle-  _ <- optional pDispatchIdLine-  rejected <- pPolicyLine "rejected"-  poison <- pPolicyLine "poison"-  timer <- pTimerNode-  pure-    ProcessNode-      { procId = pid,-        procName = nm,-        procInput = inp,-        procCorrelate = corr,-        procSaga = saga,-        procTarget = tgt,-        procProjections = projs,-        procHandle = handle,-        procRejected = rejected,-        procPoison = poison,-        procTimer = timer,-        procLoc = loc-      }--pRouter :: P RouterNode-pRouter = do-  loc <- getLoc-  keyword "router"-  rid <- ident-  keyword "name"-  nm <- stringLit-  inp <- pInputDecl-  key <- pRouterKey-  resolved <- pResolveDecl-  keyword "target"-  target <- ident-  projections <- keyword "projections" *> brackets (many ident)-  dispatch <- pRouterDispatch-  pRouterDispatchIdLine-  rejected <- pPolicyLine "rejected"-  poison <- pPolicyLine "poison"-  pure-    RouterNode-      { rtId = rid,-        rtName = nm,-        rtInput = inp,-        rtKey = key,-        rtResolve = resolved,-        rtTarget = target,-        rtProjections = projections,-        rtDispatch = dispatch,-        rtRejected = rejected,-        rtPoison = poison,-        rtLoc = loc-      }--pRouterKey :: P CorrelateDecl-pRouterKey = do-  keyword "key"-  _ <- keyword "input" *> symbol "."-  field <- ident-  keyword "via"-  via <- ident-  pure CorrelateDecl {corrField = field, corrVia = via}--pResolveDecl :: P ResolveDecl-pResolveDecl = do-  loc <- getLoc-  keyword "resolve"-  keyword "stable"-  keyword "via"-  source <- choice [ResolveReadModel <$> (keyword "read-model" *> ident), ResolveHole <$ keyword "hole"]-  keyword "row"-  row <- braces (many ident)-  pure ResolveDecl {rvSource = source, rvRow = row, rvLoc = loc}--pRouterDispatch :: P RouterDispatchNode-pRouterDispatch = do-  loc <- getLoc-  keyword "dispatch-each"-  command <- ident-  fields <- braces (many pFieldBinding)-  disposition <--    DispatchDisposition-      <$> (keyword "on-appended" *> pDisp)-      <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)-      <*> (symbol ";" *> keyword "on-failed" *> pDisp)-  pure RouterDispatchNode {rdCommand = command, rdFields = fields, rdDisposition = disposition, rdLoc = loc}--pRouterDispatchIdLine :: P ()-pRouterDispatchIdLine = do-  keyword "dispatch-id"-  _ <- symbol "strategy" *> symbol "=" *> keyword "uuidv5"-  _ <- symbol "from" *> symbol "=" *> parens fixedInputs-  pure ()-  where-    fixedInputs = do-      keyword "name"-      _ <- symbol ","-      keyword "key"-      _ <- symbol ","-      keyword "sourceEventId"-      _ <- symbol ","-      keyword "targetStreamName"-      _ <- symbol ","-      keyword "occurrence"--pPolicyLine :: Text -> P PolicyChoice-pPolicyLine clause = keyword clause *> symbol "=>" *> pPolicyChoice--pPolicyChoice :: P PolicyChoice-pPolicyChoice =-  choice-    [ PolHalt <$ keyword "halt",-      PolDeadLetter <$ keyword "deadLetter",-      PolSkip <$ keyword "skip"-    ]--pInputDecl :: P InputDecl-pInputDecl = do-  keyword "input"-  nm <- ident-  fs <- braces (many pField)-  pure InputDecl {inName = nm, inFields = fs}--pCorrelate :: P CorrelateDecl-pCorrelate = do-  keyword "correlate"-  _ <- keyword "input" *> symbol "."-  f <- ident-  keyword "via"-  v <- ident-  pure CorrelateDecl {corrField = f, corrVia = v}--pSaga :: P SagaRef-pSaga = do-  keyword "saga"-  agg <- ident-  keyword "category"-  categoryName <- stringLit-  pure SagaRef {sagaAgg = agg, sagaCategory = categoryName}--pHandle :: P HandleNode-pHandle = do-  keyword "on"-  onName <- ident-  adv <- pAdvance-  disps <- many pDispatch-  keyword "schedule"-  sched <- ident-  pure HandleNode {hOn = onName, hAdvance = adv, hDispatch = disps, hSchedule = sched}--pAdvance :: P AdvanceNode-pAdvance = do-  keyword "advance"-  cmd <- ident-  fs <- braces (many pFieldBinding)-  pure AdvanceNode {advCommand = cmd, advFields = fs}--pDispatch :: P DispatchNode-pDispatch = do-  loc <- getLoc-  keyword "dispatch"-  tgt <- ident-  _ <- symbol "@"-  key <- dottedRef-  cmd <- ident-  fs <- braces (many pFieldBinding)-  disp <--    DispatchDisposition-      <$> (keyword "on-appended" *> pDisp)-      <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)-      <*> (symbol ";" *> keyword "on-failed" *> pDisp)-  pure DispatchNode {dispTarget = tgt, dispKey = key, dispCommand = cmd, dispFields = fs, dispDisposition = disp, dispLoc = loc}--pDisp :: P Disp-pDisp =-  choice-    [ DAckOk <$ keyword "AckOk",-      DRetry <$ keyword "Retry",-      DDeadLetter <$> (keyword "DeadLetter" *> stringLit)-    ]---- The dispatch-id line is a fixed, runtime-owned strategy; parse and discard.-pDispatchIdLine :: P ()-pDispatchIdLine = do-  keyword "dispatch-id"-  _ <- symbol "strategy" *> symbol "=" *> ident-  _ <- symbol "from" *> symbol "=" *> parens (sepBy dottedRef (symbol ","))-  pure ()--pTimerNode :: P TimerNode-pTimerNode = do-  loc <- getLoc-  keyword "timer"-  nm <- ident-  tid <- keyword "id" *> pIdExpr-  fat <- keyword "fireAt" *> pFireAt-  pay <- keyword "payload" *> braces (many pFieldBinding)-  fire <- pFire-  _ <- keyword "decode" *> keyword "unknown-status" *> symbol "=>"-  unk <- ident-  keyword "max-attempts"-  ma <- boundedDecimal-  keyword "dead-letter"-  dl <- stringLit-  pure-    TimerNode-      { tmName = nm,-        tmId = tid,-        tmFireAt = fat,-        tmPayload = pay,-        tmFire = fire,-        tmDecodeUnknown = unk,-        tmMaxAttempts = ma,-        tmDeadLetter = dl,-        tmLoc = loc-      }--pIdExpr :: P IdExpr-pIdExpr = do-  keyword "uuidv5"-  pfx <- stringLit-  _ <- symbol "<>"-  _ <- ident -- correlationId (fixed)-  pure IdExpr {ideStrategy = UuidV5Id, idePrefix = pfx}--pFireAt :: P FireAtExpr-pFireAt = do-  _ <- keyword "input" *> symbol "."-  f <- ident-  _ <- symbol "+"-  w <- pWindow-  pure FireAtExpr {faField = f, faWindow = w}--pWindow :: P Text-pWindow = lexeme $ do-  ds <- some digitChar-  u <- choice [char 's', char 'm', char 'h'] <?> "time unit: s, m, or h"-  notFollowedBy letterChar <?> "time unit: s, m, or h"-  pure (T.pack (ds <> [u]))--decimalText :: P Text-decimalText = lexeme $ do-  whole <- some digitChar-  fractional <- optional (char '.' *> some digitChar)-  pure (T.pack (whole <> maybe "" ('.' :) fractional))--signedDecimalText :: P Text-signedDecimalText = lexeme $ do-  sign <- optional (char '-')-  digits <- some digitChar-  fractional <- optional (char '.' *> some digitChar)-  pure (T.pack (maybe "" pure sign <> digits <> maybe "" ('.' :) fractional))--pFire :: P FireNode-pFire = do-  keyword "fire"-  keyword "dispatch"-  tgt <- ident-  _ <- symbol "@"-  key <- dottedRef-  cmd <- ident-  fs <- braces (many pFieldBinding)-  fid <- keyword "fired-event-id" *> pIdExpr-  disp <--    FireDisposition-      <$> (keyword "on-ok" *> pFireOutcome)-      <*> (symbol ";" *> keyword "on-reject" *> pFireOutcome)-      <*> (symbol ";" *> keyword "on-ambiguous" *> pFireOutcome)-      <*> (symbol ";" *> keyword "on-error" *> pFireOutcome)-      <*> (symbol ";" *> keyword "not-mine" *> pFireOutcome)-  pure FireNode {fireTarget = tgt, fireKey = key, fireCommand = cmd, fireFields = fs, fireFiredEventId = fid, fireDisposition = disp}--pFireOutcome :: P FireOutcome-pFireOutcome = choice [OFired <$ keyword "Fired", ORetry <$ keyword "Retry"]--pFieldBinding :: P FieldBinding-pFieldBinding = do-  n <- ident-  v <- optional (symbol "=" *> pBindingValue)-  pure FieldBinding {fbName = n, fbValue = v}---- | A binding value: a quoted string (kept quoted) or a dotted reference.-pBindingValue :: P Text-pBindingValue = choice [quoted, dottedRef]-  where-    quoted = do-      s <- stringLit-      pure ("\"" <> s <> "\"")---- | A dotted/plain reference token like @input.hospitalId@, @timer.id@,--- @correlationId@.-dottedRef :: P Text-dottedRef = lexeme $ do-  c <- asciiLetter-  cs <- many (asciiAlphaNum <|> char '_' <|> char '.')-  pure (T.pack (c : cs))---- | A double-quoted string literal, returning raw (unescaped) inner text.--- The surface syntax supports a closed escape set so unknown escapes remain--- available for backward-compatible extensions.-stringLit :: P Text-stringLit = lexeme $ do-  _ <- char '"'-  s <- many strChar-  _ <- char '"'-  pure (T.pack s)-  where-    strChar =-      choice-        [ char '\\' *> escapeCode,-          char '\n' *> fail "unescaped newline in string literal (write \\n)",-          anySingleBut '"'-        ]-    escapeCode =-      choice-        [ '"' <$ char '"',-          '\\' <$ char '\\',-          '\n' <$ char 'n',-          '\t' <$ char 't',-          '\r' <$ char 'r',-          anySingle >>= \c -> fail ("unknown escape sequence \\" <> [c] <> " in string literal")-        ]--brackets :: P a -> P a-brackets = between (symbol "[") (symbol "]")------------------------------------------------------------------------------------- Transitions-----------------------------------------------------------------------------------data Clause-  = CGuard Expr-  | CWrite Name Expr-  | CEmit Name-  | CGoto Name-  | CImplementationHole--pTransition :: LanguageVersion -> P Transition-pTransition version = do-  startOffset <- getOffset-  loc <- getLoc-  -- Plan 143: a @replay-only@ prefix marks the transition as serving-  -- inversion only; it lowers to a keiki 'ReplayOnly' edge.-  mode <- option TmLive (TmReplayOnly <$ keyword "replay-only")-  src <- ident-  _ <- symbol "--"-  cmd <- ident-  _ <- symbol "-->"-  positionedClauses <- many ((,) <$> getOffset <*> (pClause version <* optional (symbol ";")))-  let clauses = map snd positionedClauses-      gotos = [(offset, target) | (offset, CGoto target) <- positionedClauses]-      holeOffsets = [offset | (offset, CImplementationHole) <- positionedClauses]-      transitionName = T.unpack src <> " -- " <> T.unpack cmd-  gt <- case gotos of-    [] -> failAt startOffset ("transition " <> transitionName <> " is missing a goto clause")-    [(_, target)] -> pure target-    (_, firstTarget) : (duplicateOffset, _) : _ ->-      failAt-        duplicateOffset-        ("duplicate goto clause (transition " <> transitionName <> " already declared goto " <> T.unpack firstTarget <> ")")-  case holeOffsets of-    _ : duplicateOffset : _ -> failAt duplicateOffset ("duplicate implementation hole clause in transition " <> transitionName)-    _ -> pure ()-  let guards = [e | CGuard e <- clauses]-  pure-    Transition-      { tSource = src,-        tCommand = cmd,-        tImplementation = case holeOffsets of-          _ : _ -> HoleImplementation-          [] | languageSupportsFeature version TypedAggregateExpressionSyntax -> GeneratedImplementation-          [] -> LegacyHoleImplementation,-        tGuard = case guards of [] -> Nothing; es -> Just (foldr1 EAnd es),-        tWrites = [(r, e) | CWrite r e <- clauses],-        tEmits = [n | CEmit n <- clauses],-        tGoto = gt,-        tMode = mode,-        tLoc = loc-      }--pClause :: LanguageVersion -> P Clause-pClause version =-  choice-    [ do-        loc <- getLoc-        keyword "implementation"-        keyword "hole"-        requireLanguageFeatureAt version ExplicitTransitionImplementationSyntax loc-        pure CImplementationHole,-      CGuard <$> (keyword "guard" *> pExpr version),-      (\r e -> CWrite r e) <$> (keyword "write" *> ident) <*> (symbol ":=" *> pExpr version),-      try $ do-        keyword "emit"-        eventName <- ident-        notFollowedBy (symbol "{")-        pure (CEmit eventName),-      CGoto <$> (keyword "goto" *> ident)-    ]------------------------------------------------------------------------------------- Expr sublanguage-----------------------------------------------------------------------------------pExpr :: LanguageVersion -> P Expr-pExpr version-  | languageSupportsFeature version TypedAggregateExpressionSyntax = makeExprParser (pScalarTerm version) scalarOperatorTable-  | otherwise = makeExprParser (pLegacyTerm version) legacyOperatorTable--pLegacyTerm :: LanguageVersion -> P Expr-pLegacyTerm version =-  choice-    [ parens (pExpr version),-      pUnsupportedScalarTerm version,-      EAtom . ABool <$> (True <$ keyword "true" <|> False <$ keyword "false"),-      EAtom . AName <$> ident-    ]--pUnsupportedScalarTerm :: LanguageVersion -> P Expr-pUnsupportedScalarTerm version = do-  loc <- getLoc-  _ <--    try ((keyword "reg" <|> keyword "cmd") *> symbol ".")-  requireLanguageFeatureAt version TypedAggregateExpressionSyntax loc-  fail "unreachable supported scalar term in predecessor grammar"---- | Highest precedence first: relational comparisons bind tighter than @&&@,--- which binds tighter than @||@.-legacyOperatorTable :: [[Operator P Expr]]-legacyOperatorTable =-  [ [InfixL arithmeticUnsupported],-    [ InfixN (ECmp OpLe <$ op "<="),-      InfixN (ECmp OpGe <$ op ">="),-      InfixN (ECmp OpEq <$ op "=="),-      InfixN (ECmp OpNeq <$ op "!="),-      InfixN (ECmp OpLt <$ op "<"),-      InfixN (ECmp OpGt <$ op ">")-    ],-    [InfixL (EAnd <$ op "&&")],-    [InfixL (EOr <$ op "||")]-  ]-  where-    op s = symbol s-    arithmeticUnsupported = do-      offset <- getOffset-      operator <- lexeme (oneOf ['+', '-', '*', '/'])-      failAt offset ("aggregate arithmetic operator '" <> [operator] <> "' is unsupported; compare or copy whole values instead")--pScalarTerm :: LanguageVersion -> P Expr-pScalarTerm version =-  choice-    [ parens (pExpr version),-      collectionTermUnsupported,-      try pIdLiteral,-      do-        loc <- getLoc-        ELiteral loc . LiteralBool <$> (True <$ keyword "true" <|> False <$ keyword "false"),-      do-        loc <- getLoc-        ELiteral loc . LiteralText <$> stringLit,-      try $ do-        loc <- getLoc-        ELiteral loc . LiteralIntegral <$> integerLiteral,-      pScalarPath-    ]--pIdLiteral :: P Expr-pIdLiteral = do-  loc <- getLoc-  constructor <- ident-  value <- parens stringLit-  pure (ELiteral loc (LiteralId constructor value))--pScalarPath :: P Expr-pScalarPath = do-  loc <- getLoc-  firstName <- ident-  rest <- many (symbol "." *> ident)-  pure $ case (firstName, rest) of-    ("reg", name : path) -> EPath loc RegisterRoot (name : path)-    ("cmd", name : path) -> EPath loc CommandRoot (name : path)-    (_, [constructor]) | startsUpper firstName -> ELiteral loc (LiteralQualified firstName constructor)-    _ -> EPath loc UnqualifiedRoot (firstName : rest)-  where-    startsUpper value = maybe False (isUpper . fst) (T.uncons value)--collectionTermUnsupported :: P Expr-collectionTermUnsupported = do-  offset <- getOffset-  choice-    [ () <$ symbol "[",-      () <$ symbol "{",-      () <$ keyword "keys",-      () <$ keyword "values",-      () <$ keyword "any",-      () <$ keyword "all"-    ]-  failAt offset collectionExpressionMessage--collectionExpressionMessage :: String-collectionExpressionMessage = "CollectionExpressionUnsupported: collection expressions are reserved for plan 166"--scalarOperatorTable :: [[Operator P Expr]]-scalarOperatorTable =-  [ [InfixL (op "*" *> located EMultiply)],-    [ InfixL (op "+" *> located EAdd),-      InfixL (op "-" *> located ESubtract),-      InfixL scalarArithmeticUnsupported-    ],-    [ InfixN (ECmp OpLe <$ op "<="),-      InfixN (ECmp OpGe <$ op ">="),-      InfixN (ECmp OpEq <$ op "=="),-      InfixN (ECmp OpNeq <$ op "!="),-      InfixN (ECmp OpLt <$ op "<"),-      InfixN (ECmp OpGt <$ op ">"),-      InfixN collectionOperatorUnsupported-    ],-    [InfixL (EAnd <$ op "&&")],-    [InfixL (EOr <$ op "||")]-  ]-  where-    op value = symbol value-    located constructor = do-      loc <- getLoc-      pure (constructor loc)-    scalarArithmeticUnsupported = do-      offset <- getOffset-      operator <- lexeme (oneOf ['/', '%'])-      failAt offset ("aggregate arithmetic operator '" <> [operator] <> "' is unsupported")-    collectionOperatorUnsupported = do-      offset <- getOffset-      _ <- try (keyword "not" *> keyword "in") <|> keyword "in"-      failAt offset collectionExpressionMessage------------------------------------------------------------------------------------- Helpers-----------------------------------------------------------------------------------braces :: P a -> P a-braces = between (symbol "{") (symbol "}")--parens :: P a -> P a-parens = between (symbol "(") (symbol ")")+-- | Stable compatibility facade for the Keiro DSL language frontend.+module Keiro.Dsl.Parser+  ( ParseError,+    ParseFailure (..),+    ParsedSource (..),+    parseSource,+    parseSpec,+    parseSpecText,+    renderParseFailure,+  )+where++import Data.Bifunctor (first)+import Data.Text (Text)+import Keiro.Dsl.Frontend (lowerSurfaceSource, parseSurfaceSource)+import Keiro.Dsl.Frontend.Internal+  ( frontendCompatibilityFailure,+    frontendFailureFromLowering,+  )+import Keiro.Dsl.Grammar (Spec)+import Keiro.Dsl.LanguageVersion++-- | A rendered, line-numbered parse error, ready to print to the user.+type ParseError = Text++-- | Parse a @.keiro@ source. The 'FilePath' is used only as the source name in+-- diagnostics; it need not exist on disk.+parseSpec :: FilePath -> Text -> Either ParseError Spec+parseSpec sourceName input = parsedSpec <$> first renderParseFailure (parseSource sourceName input)++-- | Convenience wrapper for callers without a source name (tests, stdin).+parseSpecText :: Text -> Either ParseError Spec+parseSpecText = parseSpec "<input>"++-- | Parse a source without discarding its selected language contract.+parseSource :: FilePath -> Text -> Either ParseFailure ParsedSource+parseSource sourceName input = do+  surface <- first frontendCompatibilityFailure (parseSurfaceSource sourceName input)+  first (frontendCompatibilityFailure . frontendFailureFromLowering) (lowerSurfaceSource surface)

@@ -0,0 +1,337 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | Aggregate declarations, clauses, transitions, and expression ownership.+module Keiro.Dsl.Parser.Aggregate+  ( pAggregate,+  )+where++import Data.Text qualified as T+import Keiro.Dsl.Frontend.Internal (FrontendContext, frontendSupportsFeature)+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Parser.Expression (pExpr)+import Keiro.Dsl.Parser.Mapped (pMappedTypeExpr)+import Keiro.Dsl.Source (Located, mapLocated)+import Keiro.Dsl.Syntax (SurfaceElement (..))+import Text.Megaparsec++-- Aggregate node+--------------------------------------------------------------------------------++data BodyItem+  = BICommand Command [Located SurfaceElement]+  | BIEvent Event [Located SurfaceElement]+  | BIWire WireSpec+  | BIProjection ProjectionSpec+  | BISnapshot SnapshotSpec+  | BITransition Transition [Located SurfaceElement]++pAggregate :: FrontendContext -> P (Aggregate, [Located SurfaceElement])+pAggregate context = do+  loc <- getLoc+  keyword "aggregate"+  name <- ident+  regs <- pRegsBlock context+  states <- pStatesLine+  positionedItems <- many ((,) <$> getOffset <*> pBodyItem context)+  let items = map snd positionedItems+      wireOffsets = [offset | (offset, BIWire _) <- positionedItems]+      projectionOffsets = [offset | (offset, BIProjection _) <- positionedItems]+      snapshotOffsets = [offset | (offset, BISnapshot _) <- positionedItems]+  case wireOffsets of+    _ : duplicateOffset : _ ->+      failAt duplicateOffset ("duplicate wire block in aggregate " <> T.unpack name <> " (only one is allowed)")+    _ -> pure ()+  case projectionOffsets of+    _ : duplicateOffset : _ ->+      failAt duplicateOffset ("duplicate projection block in aggregate " <> T.unpack name <> " (only one is allowed)")+    _ -> pure ()+  case snapshotOffsets of+    _ : duplicateOffset : _ ->+      failAt duplicateOffset ("duplicate snapshot block in aggregate " <> T.unpack name <> " (only one is allowed)")+    _ -> pure ()+  pure+    ( Aggregate+        { aggName = name,+          aggRegs = regs,+          aggStates = states,+          aggCommands = [c | BICommand c _ <- items],+          aggEvents = [e | BIEvent e _ <- items],+          aggTransitions = [t | BITransition t _ <- items],+          aggWire = listToMaybe [w | BIWire w <- items],+          aggProjection = listToMaybe [p | BIProjection p <- items],+          aggSnapshot = listToMaybe [s | BISnapshot s <- items],+          aggLoc = loc+        },+      concatMap bodyElements items+    )+  where+    listToMaybe xs = case xs of (x : _) -> Just x; [] -> Nothing+    bodyElements = \case+      BICommand _ elements -> elements+      BIEvent _ elements -> elements+      BITransition _ elements -> elements+      BIWire _ -> []+      BIProjection _ -> []+      BISnapshot _ -> []++pRegsBlock :: FrontendContext -> P [RegDecl]+pRegsBlock context = do+  keyword "regs"+  many (pRegDecl context)++pRegDecl :: FrontendContext -> P RegDecl+pRegDecl context = do+  loc <- getLoc+  name <- ident+  ty <- pMappedTypeExpr context+  _ <- symbol "="+  initial <- (RegInitText <$> stringLit) <|> (RegInitBare <$> (ident <|> signedDecimalText))+  pure RegDecl {regName = name, regType = ty, regInitial = initial, regLoc = loc}++pStatesLine :: P [StateDecl]+pStatesLine = do+  keyword "states"+  many pStateDecl+  where+    -- A state decl is an identifier with an optional terminal @!@. The+    -- @notFollowedBy@ lookahead stops the list before a transition whose source+    -- state would otherwise be swallowed as an extra state, e.g. when a+    -- transition directly follows the @states@ line with no command\/event+    -- between them. The @try@ backtracks so the identifier is left for+    -- 'pTransition'.+    pStateDecl = try $ do+      loc <- getLoc+      -- A @replay-only@ transition marker directly after the states line+      -- must not be swallowed: 'ident' would take @replay@ (hyphens are+      -- not identifier characters) and strand @-only@.+      notFollowedBy (keyword "replay-only")+      n <- ident+      term <- option False (True <$ symbol "!")+      notFollowedBy (symbol "--")+      pure StateDecl {stName = n, stTerminal = term, stLoc = loc}++pBodyItem :: FrontendContext -> P BodyItem+pBodyItem context =+  choice+    [ uncurry BICommand <$> pCommand context,+      uncurry BIEvent <$> pEvent context,+      BIWire <$> pWire,+      BIProjection <$> pProjection,+      BISnapshot <$> pSnapshot,+      uncurry BITransition <$> pTransition context+    ]++pSnapshot :: P SnapshotSpec+pSnapshot = do+  loc <- getLoc+  keyword "snapshot"+  policy <-+    choice+      [ SnapEvery <$> (keyword "every" *> boundedDecimal),+        SnapOnTerminal <$ symbol "on-terminal"+      ]+  _ <- symbol "state-codec"+  _ <- symbol "version" *> symbol "="+  version <- boundedDecimal+  _ <- symbol "shape-hash" *> symbol "="+  hash <- stringLit+  pure SnapshotSpec {snapPolicy = policy, snapCodecVersion = version, snapShapeHash = hash, snapLoc = loc}++pCommand :: FrontendContext -> P (Command, [Located SurfaceElement])+pCommand context = do+  loc <- getLoc+  keyword "command"+  name <- ident+  fields <- braces (many (withOwnedSpan (pAggregateField context)))+  pure+    ( Command {cmdName = name, cmdFields = map locatedValue fields, cmdLoc = loc},+      map (mapLocated (SurfaceField . aggregateFieldName)) fields+    )++pAggregateField :: FrontendContext -> P AggregateField+pAggregateField context = do+  loc <- getLoc+  n <- ident+  mty <- optional (symbol ":" *> pMappedTypeExpr context)+  pure AggregateField {aggregateFieldName = n, aggregateFieldType = mty, aggregateFieldLoc = loc}++pEvent :: FrontendContext -> P (Event, [Located SurfaceElement])+pEvent context = do+  loc <- getLoc+  (retiring, deprecated) <-+    option+      (False, False)+      ( choice+          [ (True, False) <$ keyword "retiring",+            (False, True) <$ keyword "deprecated"+          ]+      )+  keyword "event"+  name <- ident+  ver <- option 1 pVersion+  (body, elements) <-+    choice+      [ (\commandName -> (EventFromCommand commandName, [])) <$> (symbol "=" *> keyword "fields" *> parens ident),+        do+          fields <- braces (many (withOwnedSpan (pAggregateField context)))+          pure+            ( EventFields (map locatedValue fields),+              map (mapLocated (SurfaceField . aggregateFieldName)) fields+            )+      ]+  up <- optional pUpcast+  pure+    ( Event+        { evName = name,+          evBody = body,+          evVersion = ver,+          evUpcastFrom = up,+          evRetiring = retiring,+          evDeprecated = deprecated,+          evLoc = loc+        },+      elements+    )+  where+    pUpcast = do+      keyword "upcast"+      keyword "from"+      m <- pVersion+      _ <- symbol "="+      keyword "HOLE"+      pure (m, Hole)++pWire :: P WireSpec+pWire = do+  keyword "wire"+  _ <- symbol "kind"+  _ <- symbol "="+  k <- wireWord+  _ <- symbol "fields"+  _ <- symbol "="+  f <- wireWord+  _ <- symbol "schemaVersion"+  _ <- symbol "="+  v <- boundedDecimal+  pure WireSpec {wireKind = k, wireFields = f, wireSchemaVersion = v}++pProjection :: P ProjectionSpec+pProjection = do+  loc <- getLoc+  keyword "projection"+  table <- ident+  cons <- optional (symbol "consistency" *> symbol "=" *> pConsistency)+  _ <- symbol "key"+  _ <- symbol "="+  k <- ident+  sm <- optional pStatusMap+  pure+    ProjectionSpec+      { projTable = table,+        projConsistency = cons,+        projKey = k,+        projStatusMap = sm,+        projLoc = loc+      }+  where+    pConsistency =+      choice [Strong <$ keyword "Strong", Eventual <$ keyword "Eventual"]++pStatusMap :: P Mapping+pStatusMap = do+  keyword "status-map"+  partial <- option False (True <$ keyword "partial")+  pairs <- braces (many pPair)+  pure Mapping {mapPairs = pairs, mapPartial = partial}+  where+    pPair = do+      l <- ident+      _ <- symbol "=>"+      r <- wireWord+      pure (l, r)++--------------------------------------------------------------------------------+-- Transitions+--------------------------------------------------------------------------------++data Clause+  = CGuard Expr+  | CWrite Name Expr+  | CEmit Name+  | CGoto Name+  | CImplementationHole++pTransition :: FrontendContext -> P (Transition, [Located SurfaceElement])+pTransition context = do+  startOffset <- getOffset+  loc <- getLoc+  -- Plan 143: a @replay-only@ prefix marks the transition as serving+  -- inversion only; it lowers to a keiki 'ReplayOnly' edge.+  mode <- option TmLive (TmReplayOnly <$ keyword "replay-only")+  src <- ident+  _ <- symbol "--"+  cmd <- ident+  _ <- symbol "-->"+  positionedClauses <- many ((,) <$> getOffset <*> (pClause context <* optional (symbol ";")))+  let clauses = map (fst . snd) positionedClauses+      elements = concatMap (snd . snd) positionedClauses+      gotos = [(offset, target) | (offset, (CGoto target, _)) <- positionedClauses]+      holeOffsets = [offset | (offset, (CImplementationHole, _)) <- positionedClauses]+      transitionName = T.unpack src <> " -- " <> T.unpack cmd+  gt <- case gotos of+    [] -> failAt startOffset ("transition " <> transitionName <> " is missing a goto clause")+    [(_, target)] -> pure target+    (_, firstTarget) : (duplicateOffset, _) : _ ->+      failAt+        duplicateOffset+        ("duplicate goto clause (transition " <> transitionName <> " already declared goto " <> T.unpack firstTarget <> ")")+  case holeOffsets of+    _ : duplicateOffset : _ -> failAt duplicateOffset ("duplicate implementation hole clause in transition " <> transitionName)+    _ -> pure ()+  let guards = [e | CGuard e <- clauses]+  pure+    ( Transition+        { tSource = src,+          tCommand = cmd,+          tImplementation = case holeOffsets of+            _ : _ -> HoleImplementation+            [] | frontendSupportsFeature context TypedAggregateExpressionSyntax -> GeneratedImplementation+            [] -> LegacyHoleImplementation,+          tGuard = case guards of [] -> Nothing; es -> Just (foldr1 EAnd es),+          tWrites = [(r, e) | CWrite r e <- clauses],+          tEmits = [n | CEmit n <- clauses],+          tGoto = gt,+          tMode = mode,+          tLoc = loc+        },+      elements+    )++pClause :: FrontendContext -> P (Clause, [Located SurfaceElement])+pClause context =+  choice+    [ do+        marker <- withOwnedSpan (keyword "implementation" *> keyword "hole")+        requireLanguageFeatureAt context ExplicitTransitionImplementationSyntax (spanOf marker)+        pure (CImplementationHole, []),+      do+        keyword "guard"+        expression <- withOwnedSpan (pExpr context)+        pure (CGuard (locatedValue expression), [mapLocated SurfaceExpression expression]),+      do+        register <- keyword "write" *> ident+        _ <- symbol ":="+        expression <- withOwnedSpan (pExpr context)+        pure (CWrite register (locatedValue expression), [mapLocated SurfaceExpression expression]),+      try $ do+        keyword "emit"+        eventName <- ident+        notFollowedBy (symbol "{")+        pure (CEmit eventName, []),+      (\target -> (CGoto target, [])) <$> (keyword "goto" *> ident)+    ]++--------------------------------------------------------------------------------

@@ -0,0 +1,311 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | Process-manager, router, timer, dispatch, and correlation syntax.+module Keiro.Dsl.Parser.Coordination+  ( pProcess,+    pRouter,+  )+where++import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.Parser.Core+import Text.Megaparsec+import Text.Megaparsec.Char (char)++-- Process manager + durable timer (EP-3)+--------------------------------------------------------------------------------++pProcess :: P ProcessNode+pProcess = do+  loc <- getLoc+  keyword "process"+  pid <- ident+  keyword "name"+  nm <- stringLit+  inp <- pInputDecl+  corr <- pCorrelate+  saga <- pSaga+  keyword "target"+  tgt <- ident+  projs <- keyword "projections" *> brackets (many ident)+  handle <- pHandle+  _ <- optional pDispatchIdLine+  rejected <- pPolicyLine "rejected"+  poison <- pPolicyLine "poison"+  timer <- pTimerNode+  pure+    ProcessNode+      { procId = pid,+        procName = nm,+        procInput = inp,+        procCorrelate = corr,+        procSaga = saga,+        procTarget = tgt,+        procProjections = projs,+        procHandle = handle,+        procRejected = rejected,+        procPoison = poison,+        procTimer = timer,+        procLoc = loc+      }++pRouter :: P RouterNode+pRouter = do+  loc <- getLoc+  keyword "router"+  rid <- ident+  keyword "name"+  nm <- stringLit+  inp <- pInputDecl+  key <- pRouterKey+  resolved <- pResolveDecl+  keyword "target"+  target <- ident+  projections <- keyword "projections" *> brackets (many ident)+  dispatch <- pRouterDispatch+  pRouterDispatchIdLine+  rejected <- pPolicyLine "rejected"+  poison <- pPolicyLine "poison"+  pure+    RouterNode+      { rtId = rid,+        rtName = nm,+        rtInput = inp,+        rtKey = key,+        rtResolve = resolved,+        rtTarget = target,+        rtProjections = projections,+        rtDispatch = dispatch,+        rtRejected = rejected,+        rtPoison = poison,+        rtLoc = loc+      }++pRouterKey :: P CorrelateDecl+pRouterKey = do+  keyword "key"+  _ <- keyword "input" *> symbol "."+  field <- ident+  keyword "via"+  via <- ident+  pure CorrelateDecl {corrField = field, corrVia = via}++pResolveDecl :: P ResolveDecl+pResolveDecl = do+  loc <- getLoc+  keyword "resolve"+  keyword "stable"+  keyword "via"+  source <- choice [ResolveReadModel <$> (keyword "read-model" *> ident), ResolveHole <$ keyword "hole"]+  keyword "row"+  row <- braces (many ident)+  pure ResolveDecl {rvSource = source, rvRow = row, rvLoc = loc}++pRouterDispatch :: P RouterDispatchNode+pRouterDispatch = do+  loc <- getLoc+  keyword "dispatch-each"+  command <- ident+  fields <- braces (many pFieldBinding)+  disposition <-+    DispatchDisposition+      <$> (keyword "on-appended" *> pDisp)+      <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)+      <*> (symbol ";" *> keyword "on-failed" *> pDisp)+  pure RouterDispatchNode {rdCommand = command, rdFields = fields, rdDisposition = disposition, rdLoc = loc}++pRouterDispatchIdLine :: P ()+pRouterDispatchIdLine = do+  keyword "dispatch-id"+  _ <- symbol "strategy" *> symbol "=" *> keyword "uuidv5"+  _ <- symbol "from" *> symbol "=" *> parens fixedInputs+  pure ()+  where+    fixedInputs = do+      keyword "name"+      _ <- symbol ","+      keyword "key"+      _ <- symbol ","+      keyword "sourceEventId"+      _ <- symbol ","+      keyword "targetStreamName"+      _ <- symbol ","+      keyword "occurrence"++pPolicyLine :: Text -> P PolicyChoice+pPolicyLine clause = keyword clause *> symbol "=>" *> pPolicyChoice++pPolicyChoice :: P PolicyChoice+pPolicyChoice =+  choice+    [ PolHalt <$ keyword "halt",+      PolDeadLetter <$ keyword "deadLetter",+      PolSkip <$ keyword "skip"+    ]++pInputDecl :: P InputDecl+pInputDecl = do+  keyword "input"+  nm <- ident+  fs <- braces (many pField)+  pure InputDecl {inName = nm, inFields = fs}++pCorrelate :: P CorrelateDecl+pCorrelate = do+  keyword "correlate"+  _ <- keyword "input" *> symbol "."+  f <- ident+  keyword "via"+  v <- ident+  pure CorrelateDecl {corrField = f, corrVia = v}++pSaga :: P SagaRef+pSaga = do+  keyword "saga"+  agg <- ident+  keyword "category"+  categoryName <- stringLit+  pure SagaRef {sagaAgg = agg, sagaCategory = categoryName}++pHandle :: P HandleNode+pHandle = do+  keyword "on"+  onName <- ident+  adv <- pAdvance+  disps <- many pDispatch+  keyword "schedule"+  sched <- ident+  pure HandleNode {hOn = onName, hAdvance = adv, hDispatch = disps, hSchedule = sched}++pAdvance :: P AdvanceNode+pAdvance = do+  keyword "advance"+  cmd <- ident+  fs <- braces (many pFieldBinding)+  pure AdvanceNode {advCommand = cmd, advFields = fs}++pDispatch :: P DispatchNode+pDispatch = do+  loc <- getLoc+  keyword "dispatch"+  tgt <- ident+  _ <- symbol "@"+  key <- dottedRef+  cmd <- ident+  fs <- braces (many pFieldBinding)+  disp <-+    DispatchDisposition+      <$> (keyword "on-appended" *> pDisp)+      <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)+      <*> (symbol ";" *> keyword "on-failed" *> pDisp)+  pure DispatchNode {dispTarget = tgt, dispKey = key, dispCommand = cmd, dispFields = fs, dispDisposition = disp, dispLoc = loc}++pDisp :: P Disp+pDisp =+  choice+    [ DAckOk <$ keyword "AckOk",+      DRetry <$ keyword "Retry",+      DDeadLetter <$> (keyword "DeadLetter" *> stringLit)+    ]++-- The dispatch-id line is a fixed, runtime-owned strategy; parse and discard.+pDispatchIdLine :: P ()+pDispatchIdLine = do+  keyword "dispatch-id"+  _ <- symbol "strategy" *> symbol "=" *> ident+  _ <- symbol "from" *> symbol "=" *> parens (sepBy dottedRef (symbol ","))+  pure ()++pTimerNode :: P TimerNode+pTimerNode = do+  loc <- getLoc+  keyword "timer"+  nm <- ident+  tid <- keyword "id" *> pIdExpr+  fat <- keyword "fireAt" *> pFireAt+  pay <- keyword "payload" *> braces (many pFieldBinding)+  fire <- pFire+  _ <- keyword "decode" *> keyword "unknown-status" *> symbol "=>"+  unk <- ident+  keyword "max-attempts"+  ma <- boundedDecimal+  keyword "dead-letter"+  dl <- stringLit+  pure+    TimerNode+      { tmName = nm,+        tmId = tid,+        tmFireAt = fat,+        tmPayload = pay,+        tmFire = fire,+        tmDecodeUnknown = unk,+        tmMaxAttempts = ma,+        tmDeadLetter = dl,+        tmLoc = loc+      }++pIdExpr :: P IdExpr+pIdExpr = do+  keyword "uuidv5"+  pfx <- stringLit+  _ <- symbol "<>"+  _ <- ident -- correlationId (fixed)+  pure IdExpr {ideStrategy = UuidV5Id, idePrefix = pfx}++pFireAt :: P FireAtExpr+pFireAt = do+  _ <- keyword "input" *> symbol "."+  f <- ident+  _ <- symbol "+"+  w <- pWindow+  pure FireAtExpr {faField = f, faWindow = w}++pFire :: P FireNode+pFire = do+  keyword "fire"+  keyword "dispatch"+  tgt <- ident+  _ <- symbol "@"+  key <- dottedRef+  cmd <- ident+  fs <- braces (many pFieldBinding)+  fid <- keyword "fired-event-id" *> pIdExpr+  disp <-+    FireDisposition+      <$> (keyword "on-ok" *> pFireOutcome)+      <*> (symbol ";" *> keyword "on-reject" *> pFireOutcome)+      <*> (symbol ";" *> keyword "on-ambiguous" *> pFireOutcome)+      <*> (symbol ";" *> keyword "on-error" *> pFireOutcome)+      <*> (symbol ";" *> keyword "not-mine" *> pFireOutcome)+  pure FireNode {fireTarget = tgt, fireKey = key, fireCommand = cmd, fireFields = fs, fireFiredEventId = fid, fireDisposition = disp}++pFireOutcome :: P FireOutcome+pFireOutcome = choice [OFired <$ keyword "Fired", ORetry <$ keyword "Retry"]++pFieldBinding :: P FieldBinding+pFieldBinding = do+  n <- ident+  v <- optional (symbol "=" *> pBindingValue)+  pure FieldBinding {fbName = n, fbValue = v}++-- | A binding value: a quoted string (kept quoted) or a dotted reference.+pBindingValue :: P Text+pBindingValue = choice [quoted, dottedRef]+  where+    quoted = do+      s <- stringLit+      pure ("\"" <> s <> "\"")++-- | A dotted/plain reference token like @input.hospitalId@, @timer.id@,+-- @correlationId@.+dottedRef :: P Text+dottedRef = lexeme $ do+  c <- asciiLetter+  cs <- many (asciiAlphaNum <|> char '_' <|> char '.')+  pure (T.pack (c : cs))++-- | A double-quoted string literal, returning raw (unescaped) inner text.+-- The surface syntax supports a closed escape set so unknown escapes remain+-- available for backward-compatible extensions.

@@ -0,0 +1,450 @@+{-# LANGUAGE ImportQualifiedPost #-}+-- EP-4 integration: structural keywords never used as identifiers, so a+-- list like @accept A B C@ stops at the next block keyword.+-- EP-5 pgmq structural keywords.+-- EP-6 workflow/operation: reserved so the multi-word result-type parse and+-- node boundaries don't swallow the next block keyword.+-- EP-107 read-model structural words. Clause labels such as table and+-- schema remain usable identifiers because their block parser consumes+-- them with symbol-style matching.+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------+{-# LANGUAGE ImportQualifiedPost #-}++-- | Parser primitives shared by every internal grammar concern.+module Keiro.Dsl.Parser.Core+  ( ContextualParseFailure (..),+    P,+    firstContextualFailure,+    bundleFailureSpan,+    bundleExpected,+    bundleMessage,+    contextualFailureAt,+    requireLanguageFeatureAt,+    sc,+    lexeme,+    symbol,+    keyword,+    identChar,+    asciiLetter,+    asciiUpper,+    asciiDigit,+    asciiAlphaNum,+    failAt,+    boundedDecimal,+    checkedDecimal,+    reservedWords,+    ident,+    wireWord,+    patchIdWord,+    getLoc,+    withOwnedSpan,+    spanOf,+    locatedValue,+    optionalLanguageFeature,+    pField,+    pVersion,+    pWindow,+    decimalText,+    signedDecimalText,+    integerLiteral,+    stringLit,+    brackets,+    braces,+    parens,+    pModulePrefix,+  )+where++import Data.Char (isAlpha, isAlphaNum, isAscii, isDigit, isSpace, isUpper)+import Data.List.NonEmpty qualified as NE+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Frontend.Internal+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Source+import Text.Megaparsec+import Text.Megaparsec.Char (char, digitChar, letterChar, space1)+import Text.Megaparsec.Char.Lexer qualified as L+import Prelude hiding (span)++data ContextualParseFailure = ContextualParseFailure+  { contextualFailureCode :: !SourceLanguageErrorCode,+    contextualFailureFeature :: !(Maybe LanguageFeature),+    contextualFailureSpan :: !SourceSpan+  }+  deriving stock (Eq, Ord, Show)++instance ShowErrorComponent ContextualParseFailure where+  showErrorComponent contextual = T.unpack (sourceLanguageErrorCodeText (contextualFailureCode contextual))++type P = Parsec ContextualParseFailure Text++firstContextualFailure :: ParseErrorBundle Text ContextualParseFailure -> Maybe ContextualParseFailure+firstContextualFailure bundle =+  case [ contextual+       | FancyError _ fancy <- NE.toList (bundleErrors bundle),+         ErrorCustom contextual <- Set.toList fancy+       ] of+    contextual : _ -> Just contextual+    [] -> Nothing++bundleFailureSpan :: ParseErrorBundle Text e -> SourceSpan+bundleFailureSpan bundle =+  SourceSpan+    { source = sourceName position,+      start = point,+      end = point+    }+  where+    offset = errorOffset (NE.head (bundleErrors bundle))+    reachedState = reachOffsetNoLine offset (bundlePosState bundle)+    position = pstateSourcePos reachedState+    point = sourcePointAt offset position++bundleExpected :: ParseErrorBundle Text e -> [Text]+bundleExpected bundle =+  case NE.head (bundleErrors bundle) of+    TrivialError _ _ expected -> map (T.pack . show) (Set.toList expected)+    FancyError {} -> []++bundleMessage :: ParseErrorBundle Text ContextualParseFailure -> Text+bundleMessage = T.pack . parseErrorTextPretty . NE.head . bundleErrors++contextualFailureAt :: SourceSpan -> SourceLanguageErrorCode -> P a+contextualFailureAt span code =+  customFailure ContextualParseFailure {contextualFailureCode = code, contextualFailureFeature = Nothing, contextualFailureSpan = span}++requireLanguageFeatureAt :: FrontendContext -> LanguageFeature -> SourceSpan -> P ()+requireLanguageFeatureAt context feature span+  | frontendSupportsFeature context feature = pure ()+  | otherwise =+      customFailure+        ContextualParseFailure+          { contextualFailureCode = LanguageFeatureRequiresVersion,+            contextualFailureFeature = Just feature,+            contextualFailureSpan = span+          }++-- | Space consumer: spaces, newlines, and @#@ line comments are all whitespace.+sc :: P ()+sc = L.space space1 (L.skipLineComment "#") empty++lexeme :: P a -> P a+lexeme = L.lexeme sc++symbol :: Text -> P Text+symbol = L.symbol sc++-- | A reserved keyword: the literal word not followed by an identifier+-- character (so @goto@ matches @goto@ but not @gotoX@).+keyword :: Text -> P ()+keyword w = (lexeme . try) (string' w *> notFollowedBy (identChar <|> (char '-' *> identChar)))+  where+    string' = chunk++identChar :: P Char+identChar = asciiAlphaNum <|> char '_'++asciiLetter :: P Char+asciiLetter = satisfy (\c -> isAscii c && isAlpha c)++asciiUpper :: P Char+asciiUpper = satisfy (\c -> isAscii c && isUpper c)++asciiDigit :: P Char+asciiDigit = satisfy (\c -> isAscii c && isDigit c)++asciiAlphaNum :: P Char+asciiAlphaNum = satisfy (\c -> isAscii c && isAlphaNum c)++-- | Fail with the diagnostic caret placed at a previously captured offset.+failAt :: Int -> String -> P a+failAt offset message = region (setErrorOffset offset) (fail message)++-- | Parse a decimal as an unbounded Integer, then reject values that cannot be+-- represented as Int. Parsing L.decimal directly at Int silently wraps.+boundedDecimal :: P Int+boundedDecimal = do+  offset <- getOffset+  value <- lexeme (L.decimal :: P Integer)+  checkedDecimal offset value++checkedDecimal :: Int -> Integer -> P Int+checkedDecimal offset value+  | value > fromIntegral (maxBound :: Int) =+      failAt+        offset+        ( "decimal literal "+            <> show value+            <> " is out of range (maximum "+            <> show (maxBound :: Int)+            <> ")"+        )+  | otherwise = pure (fromIntegral value)++-- | Words that may not be used as bare identifiers, because they introduce a+-- different construct and would otherwise be swallowed (e.g. @aggregate@ ending+-- one node and beginning the next).+reservedWords :: [Text]+reservedWords =+  [ "context",+    "module",+    "layout",+    "prefixed",+    "collocated",+    "id",+    "enum",+    "rule",+    "mapped",+    "ex",+    "aggregate",+    "regs",+    "states",+    "command",+    "event",+    "wire",+    "projection",+    "snapshot",+    "category",+    "guard",+    "write",+    "emit",+    "goto",+    "fields",+    "status-map",+    "true",+    "false",+    "retiring",+    "deprecated",+    "upcast",+    "from",+    "HOLE",+    "process",+    "router",+    "dispatch-each",+    "resolve",+    "read-model",+    "dispatch",+    "intake",+    "contract",+    "topic",+    "accept",+    "bind",+    "dedupe",+    "persist",+    "decode",+    "disposition",+    "publisher",+    "map",+    "workqueue",+    "queue",+    "payload",+    "retry",+    "fanout",+    "dedup",+    "enqueue",+    "seenIn",+    "workflow",+    "operation",+    "consistency",+    "body",+    "step",+    "await",+    "sleep",+    "child",+    "patch",+    "continueAsNew",+    "readmodel",+    "columns",+    "feed",+    "scope",+    "shape"+  ]++-- | A CamelCase / snake_case identifier (no dashes): type names, register+-- names, command\/event\/state names, enum constructors, projection keys.+ident :: P Name+ident = (lexeme . try) $ do+  c <- asciiLetter <|> char '_'+  cs <- many identChar+  let w = T.pack (c : cs)+  if w `elem` reservedWords+    then fail ("unexpected reserved word " <> T.unpack w)+    else pure w++-- | A wire-spelling token, which may contain dashes (@partial-divert@,+-- @hospital-capacity@). Used for the context name, id prefixes, enum wire+-- spellings, and status-map values.+wireWord :: P Text+wireWord = lexeme $ do+  c <- asciiLetter <|> asciiDigit+  cs <- many (identChar <|> char '-')+  pure (T.pack (c : cs))++-- | Patch ids use wire-word spelling, but admit @:@ so the validator can emit+-- the domain-specific 'WorkflowPatchIdInvalid' diagnostic at the owning item.+patchIdWord :: P Text+patchIdWord = lexeme $ do+  c <- asciiLetter <|> asciiDigit+  cs <- many (identChar <|> char '-' <|> char ':')+  pure (T.pack (c : cs))++getLoc :: P Loc+getLoc = (Loc . unPos . sourceLine) <$> getSourcePos++-- | Attach the exact syntax owned by a production. Existing token parsers+-- consume following trivia, so the consumed slice is scanned to exclude final+-- whitespace and @#@ comments from the half-open end point.+withOwnedSpan :: P a -> P (Located a)+withOwnedSpan parser = do+  startOffset <- getOffset+  startPosition <- getSourcePos+  startState <- getParserState+  inputBefore <- getInput+  value <- parser+  inputAfter <- getInput+  let consumedLength = T.length inputBefore - T.length inputAfter+      ownedLength = ownedSyntaxLength (T.take consumedLength inputBefore)+      endOffset = startOffset + ownedLength+      endPosition = pstateSourcePos (reachOffsetNoLine endOffset (statePosState startState))+      span =+        SourceSpan+          { source = sourceName startPosition,+            start = sourcePointAt startOffset startPosition,+            end = sourcePointAt endOffset endPosition+          }+  pure Located {span, value}++sourcePointAt :: Int -> SourcePos -> SourcePoint+sourcePointAt offset position =+  SourcePoint+    { offset,+      line = unPos (sourceLine position),+      column = unPos (sourceColumn position)+    }++spanOf :: Located a -> SourceSpan+spanOf Located {span} = span++locatedValue :: Located a -> a+locatedValue Located {value} = value++data TriviaScan+  = InSyntax+  | InString !Bool+  | InComment++ownedSyntaxLength :: Text -> Int+ownedSyntaxLength = go 0 InSyntax 0 . T.unpack+  where+    go _ _ lastOwned [] = lastOwned+    go index mode lastOwned (character : rest) =+      case mode of+        InComment+          | character == '\n' || character == '\r' -> go (index + 1) InSyntax lastOwned rest+          | otherwise -> go (index + 1) InComment lastOwned rest+        InString escaped+          | escaped -> go (index + 1) (InString False) (index + 1) rest+          | character == '\\' -> go (index + 1) (InString True) (index + 1) rest+          | character == '"' -> go (index + 1) InSyntax (index + 1) rest+          | otherwise -> go (index + 1) (InString False) (index + 1) rest+        InSyntax+          | character == '#' -> go (index + 1) InComment lastOwned rest+          | character == '"' -> go (index + 1) (InString False) (index + 1) rest+          | isSpace character -> go (index + 1) InSyntax lastOwned rest+          | otherwise -> go (index + 1) InSyntax (index + 1) rest++optionalLanguageFeature :: FrontendContext -> LanguageFeature -> Text -> P a -> P (Maybe a)+optionalLanguageFeature context feature marker parser+  | frontendSupportsFeature context feature = optional parser+  | otherwise = reject <|> pure Nothing+  where+    reject = do+      locatedMarker <- withOwnedSpan (try (keyword marker))+      requireLanguageFeatureAt context feature (spanOf locatedMarker)+      fail "unreachable enabled feature in predecessor grammar"++pField :: P Field+pField = do+  n <- ident+  mty <- optional (symbol ":" *> ident)+  pure Field {fieldName = n, fieldType = mty}++pVersion :: P Int+pVersion = do+  offset <- getOffset+  value <- lexeme (try (char 'v' *> (L.decimal :: P Integer) <* notFollowedBy identChar))+  checkedDecimal offset value++pWindow :: P Text+pWindow = lexeme $ do+  ds <- some digitChar+  u <- choice [char 's', char 'm', char 'h'] <?> "time unit: s, m, or h"+  notFollowedBy letterChar <?> "time unit: s, m, or h"+  pure (T.pack (ds <> [u]))++decimalText :: P Text+decimalText = lexeme $ do+  whole <- some digitChar+  fractional <- optional (char '.' *> some digitChar)+  pure (T.pack (whole <> maybe "" ('.' :) fractional))++signedDecimalText :: P Text+signedDecimalText = lexeme $ do+  sign <- optional (char '-')+  digits <- some digitChar+  fractional <- optional (char '.' *> some digitChar)+  pure (T.pack (maybe "" pure sign <> digits <> maybe "" ('.' :) fractional))++integerLiteral :: P Integer+integerLiteral = lexeme (L.signed (pure ()) L.decimal)++stringLit :: P Text+stringLit = lexeme $ do+  _ <- char '"'+  s <- many strChar+  _ <- char '"'+  pure (T.pack s)+  where+    strChar =+      choice+        [ char '\\' *> escapeCode,+          char '\n' *> fail "unescaped newline in string literal (write \\n)",+          anySingleBut '"'+        ]+    escapeCode =+      choice+        [ '"' <$ char '"',+          '\\' <$ char '\\',+          '\n' <$ char 'n',+          '\t' <$ char 't',+          '\r' <$ char 'r',+          anySingle >>= \c -> fail ("unknown escape sequence \\" <> [c] <> " in string literal")+        ]++brackets :: P a -> P a+brackets = between (symbol "[") (symbol "]")++braces :: P a -> P a+braces = between (symbol "{") (symbol "}")++parens :: P a -> P a+parens = between (symbol "(") (symbol ")")++-- | A dotted module prefix with one or more PascalCase segments.+pModulePrefix :: P Text+pModulePrefix = lexeme $ do+  seg0 <- pSeg+  segs <- many (char '.' *> pSeg)+  pure (T.intercalate "." (seg0 : segs))+  where+    pSeg = do+      c <- asciiUpper+      cs <- many identChar+      pure (T.pack (c : cs))

@@ -0,0 +1,73 @@+-- | Shared ID, enum, and rule declarations.+module Keiro.Dsl.Parser.Declaration+  ( pIdDecl,+    pEnumDecl,+    pRuleDecl,+  )+where++import Keiro.Dsl.Frontend.Internal (FrontendContext)+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Parser.Expression (pExpr)+import Keiro.Dsl.Parser.Mapped (pUsingNominalBinding)+import Keiro.Dsl.Source (Located, mapLocated)+import Keiro.Dsl.Syntax (SurfaceElement (..))+import Text.Megaparsec (many, sepBy1)++pIdDecl :: FrontendContext -> P IdDecl+pIdDecl context = do+  loc <- getLoc+  keyword "id"+  name <- ident+  _ <- symbol "prefix"+  _ <- symbol "="+  pfx <- wireWord+  binding <- optionalLanguageFeature context NominalBindingSyntax "using" pUsingNominalBinding+  pure IdDecl {idName = name, idPrefix = pfx, idBinding = binding, idLoc = loc}++pEnumDecl :: FrontendContext -> P EnumDecl+pEnumDecl context = do+  loc <- getLoc+  keyword "enum"+  name <- ident+  ctors <- braces (many pEnumCtor)+  binding <- optionalLanguageFeature context NominalBindingSyntax "using" pUsingNominalBinding+  pure EnumDecl {enumName = name, enumCtors = ctors, enumBinding = binding, enumLoc = loc}+  where+    pEnumCtor = do+      c <- ident+      _ <- symbol "="+      w <- wireWord+      pure (c, w)++pRuleDecl :: FrontendContext -> P (RuleDecl, [Located SurfaceElement])+pRuleDecl context = do+  loc <- getLoc+  keyword "rule"+  name <- ident+  _ <- symbol ":"+  dom <- ident+  _ <- symbol "->"+  cod <- ident+  keyword "ex"+  parsedCases <- sepBy1 pCase (symbol ";")+  let cases = map fst parsedCases+      elements = map snd parsedCases+  pure+    ( RuleDecl+        { ruleName = name,+          ruleDomain = dom,+          ruleCodomain = cod,+          ruleCases = cases,+          ruleLoc = loc+        },+      elements+    )+  where+    pCase = do+      c <- ident+      _ <- symbol "=>"+      expression <- withOwnedSpan (pExpr context)+      pure ((c, locatedValue expression), mapLocated SurfaceExpression expression)

@@ -0,0 +1,147 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | Released-language dispatch and complete document composition.+module Keiro.Dsl.Parser.Document+  ( parseSurfaceSource,+  )+where++import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Frontend.Internal+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser.Aggregate (pAggregate)+import Keiro.Dsl.Parser.Coordination (pProcess, pRouter)+import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Parser.Declaration (pEnumDecl, pIdDecl, pRuleDecl)+import Keiro.Dsl.Parser.Integration (pContract, pEmit, pIntake, pPublisher)+import Keiro.Dsl.Parser.Mapped (pMappedTopItem)+import Keiro.Dsl.Parser.Preamble+import Keiro.Dsl.Parser.Queue (pPgmqDispatch, pWorkqueue)+import Keiro.Dsl.Parser.ReadModel (pReadModel)+import Keiro.Dsl.Parser.Workflow (pOperation, pWorkflow)+import Keiro.Dsl.Source+import Keiro.Dsl.Syntax+import Text.Megaparsec+import Prelude hiding (span)++parseSurfaceSource :: FilePath -> Text -> Either FrontendFailure SurfaceSource+parseSurfaceSource src input = do+  sourceLanguage <- selectSourceLanguage src input+  definition <- case lookupLanguageDefinition (effectiveLanguageVersion sourceLanguage) of+    Just value -> Right value+    Nothing -> error "keiro-dsl internal invariant: source selection returned an unregistered language"+  parseSelectedBody FrontendContext {source = src, language = sourceLanguage, definition}+  where+    parseSelectedBody context@FrontendContext {language = sourceLanguage} =+      let laterPreambleCode = case sourceLanguage of+            LegacyUnversioned -> MisplacedLanguagePreamble+            DeclaredLanguage {} -> DuplicateLanguagePreamble+          parser =+            sc+              *> case sourceLanguage of+                LegacyUnversioned -> pSurfaceDocument context Nothing laterPreambleCode <* eof+                DeclaredLanguage {} -> do+                  locatedPreamble <- withOwnedSpan (sourceLanguage <$ pDeclaredPreamble)+                  pSurfaceDocument context (Just locatedPreamble) laterPreambleCode <* eof+       in case runParser parser src input of+            Left bundle -> case firstContextualFailure bundle of+              Just contextual ->+                let diagnostic = contextualDiagnostic src sourceLanguage contextual+                    supported = languageVersionsSupportingFeature <$> contextualFailureFeature contextual+                 in Left (frontendFailureFromSourceDiagnostic BodyParsingPhase (contextualFailureSpan contextual) supported diagnostic)+              Nothing ->+                Left+                  ( frontendFailureFromBody+                      BodyParsingPhase+                      (bundleFailureSpan bundle)+                      (bundleMessage bundle)+                      (bundleExpected bundle)+                      (BodyGrammarFailure (T.pack (errorBundlePretty bundle)))+                  )+            Right surface -> Right surface++-- Top level+--------------------------------------------------------------------------------++pContextualPreamble :: SourceLanguageErrorCode -> P a+pContextualPreamble code = do+  locatedPreamble <- withOwnedSpan (try pDeclaredPreamble)+  contextualFailureAt (spanOf locatedPreamble) code++pSurfaceDocument :: FrontendContext -> Maybe (Located SourceLanguage) -> SourceLanguageErrorCode -> P SurfaceSource+pSurfaceDocument context@FrontendContext {source = sourceName, language = sourceLanguage} preamble laterPreambleCode = do+  spec <- pSurfaceSpec context laterPreambleCode+  pure SurfaceSource {source = sourceName, language = sourceLanguage, preamble, spec}++pSurfaceSpec :: FrontendContext -> SourceLanguageErrorCode -> P (Located SurfaceSpec)+pSurfaceSpec context laterPreambleCode = do+  pContextualPreamble laterPreambleCode <|> pure ()+  locatedContext <- withOwnedSpan (keyword "context" *> wireWord)+  moduleRoot <- optional (withOwnedSpan pModuleClause)+  layout <- optional (withOwnedSpan pLayoutClause)+  parsedItems <- many (withOwnedSpan (pTopItem context laterPreambleCode))+  let items = map surfaceItem parsedItems+      elements = concatMap surfaceElements parsedItems+  let contextSpan@SourceSpan {source, start} = spanOf locatedContext+      finalSpan = case reverse items of+        item : _ -> spanOf item+        [] -> case layout of+          Just value -> spanOf value+          Nothing -> maybe contextSpan spanOf moduleRoot+      SourceSpan {end} = finalSpan+  pure+    Located+      { span = SourceSpan {source, start, end},+        value = SurfaceSpec {context = locatedContext, moduleRoot, layout, items, elements}+      }+  where+    surfaceItem Located {span, value = ParsedTopItem item _} = Located {span, value = item}+    surfaceElements Located {value = ParsedTopItem _ elements} = elements++-- | @module Acme.Services@ — the optional namespace-prefix clause.+pModuleClause :: P Text+pModuleClause = keyword "module" *> pModulePrefix++-- | @layout (prefixed|collocated)@ — the optional placement-style clause.+pLayoutClause :: P Placement+pLayoutClause =+  keyword "layout"+    *> choice+      [ GeneratedPrefix <$ keyword "prefixed",+        CollocatedLeaf <$ keyword "collocated"+      ]++-- | A parsed top-level value plus any nested syntax evidence it owns.+data ParsedTopItem = ParsedTopItem !SurfaceTopItem ![Located SurfaceElement]++pTopItem :: FrontendContext -> SourceLanguageErrorCode -> P ParsedTopItem+pTopItem context laterPreambleCode =+  choice+    ( [ pContextualPreamble laterPreambleCode,+        plain (SurfaceId <$> pIdDecl context),+        plain (SurfaceEnum <$> pEnumDecl context),+        do+          (rule, elements) <- pRuleDecl context+          pure (ParsedTopItem (SurfaceRule rule) elements),+        plain (pMappedTopItem context)+      ]+        ++ [ plain (SurfaceNode . NRouter <$> pRouter),+             plain (SurfaceNode . NProcess <$> pProcess),+             plain (SurfaceNode . NContract <$> pContract),+             plain (SurfaceNode . NIntake <$> pIntake),+             plain (SurfaceNode . NEmit <$> pEmit),+             plain (SurfaceNode . NPublisher <$> pPublisher),+             plain (SurfaceNode . NWorkqueue <$> pWorkqueue),+             plain (SurfaceNode . NPgmqDispatch <$> pPgmqDispatch),+             plain (SurfaceNode . NReadModel <$> pReadModel),+             plain (SurfaceNode . NWorkflow <$> pWorkflow),+             plain (SurfaceNode . NOperation <$> pOperation),+             do+               (aggregate, elements) <- pAggregate context+               pure (ParsedTopItem (SurfaceNode (NAggregate aggregate)) elements)+           ]+    )+  where+    plain parser = (`ParsedTopItem` []) <$> parser

@@ -0,0 +1,149 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | Legacy and typed scalar expression syntax.+module Keiro.Dsl.Parser.Expression+  ( pExpr,+  )+where++import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)+import Data.Char (isUpper)+import Data.Text qualified as T+import Keiro.Dsl.Frontend.Internal (FrontendContext, frontendSupportsFeature)+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser.Core+import Text.Megaparsec++-- Expr sublanguage+--------------------------------------------------------------------------------++pExpr :: FrontendContext -> P Expr+pExpr context+  | frontendSupportsFeature context TypedAggregateExpressionSyntax = makeExprParser (pScalarTerm context) scalarOperatorTable+  | otherwise = makeExprParser (pLegacyTerm context) legacyOperatorTable++pLegacyTerm :: FrontendContext -> P Expr+pLegacyTerm context =+  choice+    [ parens (pExpr context),+      pUnsupportedScalarTerm context,+      EAtom . ABool <$> (True <$ keyword "true" <|> False <$ keyword "false"),+      EAtom . AName <$> ident+    ]++pUnsupportedScalarTerm :: FrontendContext -> P Expr+pUnsupportedScalarTerm context = do+  locatedRoot <- withOwnedSpan (try ((keyword "reg" <|> keyword "cmd") *> symbol "."))+  requireLanguageFeatureAt context TypedAggregateExpressionSyntax (spanOf locatedRoot)+  fail "unreachable supported scalar term in predecessor grammar"++-- | Highest precedence first: relational comparisons bind tighter than @&&@,+-- which binds tighter than @||@.+legacyOperatorTable :: [[Operator P Expr]]+legacyOperatorTable =+  [ [InfixL arithmeticUnsupported],+    [ InfixN (ECmp OpLe <$ op "<="),+      InfixN (ECmp OpGe <$ op ">="),+      InfixN (ECmp OpEq <$ op "=="),+      InfixN (ECmp OpNeq <$ op "!="),+      InfixN (ECmp OpLt <$ op "<"),+      InfixN (ECmp OpGt <$ op ">")+    ],+    [InfixL (EAnd <$ op "&&")],+    [InfixL (EOr <$ op "||")]+  ]+  where+    op s = symbol s+    arithmeticUnsupported = do+      offset <- getOffset+      operator <- lexeme (oneOf ['+', '-', '*', '/'])+      failAt offset ("aggregate arithmetic operator '" <> [operator] <> "' is unsupported; compare or copy whole values instead")++pScalarTerm :: FrontendContext -> P Expr+pScalarTerm context =+  choice+    [ parens (pExpr context),+      collectionTermUnsupported,+      try pIdLiteral,+      do+        loc <- getLoc+        ELiteral loc . LiteralBool <$> (True <$ keyword "true" <|> False <$ keyword "false"),+      do+        loc <- getLoc+        ELiteral loc . LiteralText <$> stringLit,+      try $ do+        loc <- getLoc+        ELiteral loc . LiteralIntegral <$> integerLiteral,+      pScalarPath+    ]++pIdLiteral :: P Expr+pIdLiteral = do+  loc <- getLoc+  constructor <- ident+  value <- parens stringLit+  pure (ELiteral loc (LiteralId constructor value))++pScalarPath :: P Expr+pScalarPath = do+  loc <- getLoc+  firstName <- ident+  rest <- many (symbol "." *> ident)+  pure $ case (firstName, rest) of+    ("reg", name : path) -> EPath loc RegisterRoot (name : path)+    ("cmd", name : path) -> EPath loc CommandRoot (name : path)+    (_, [constructor]) | startsUpper firstName -> ELiteral loc (LiteralQualified firstName constructor)+    _ -> EPath loc UnqualifiedRoot (firstName : rest)+  where+    startsUpper value = maybe False (isUpper . fst) (T.uncons value)++collectionTermUnsupported :: P Expr+collectionTermUnsupported = do+  offset <- getOffset+  choice+    [ () <$ symbol "[",+      () <$ symbol "{",+      () <$ keyword "keys",+      () <$ keyword "values",+      () <$ keyword "any",+      () <$ keyword "all"+    ]+  failAt offset collectionExpressionMessage++collectionExpressionMessage :: String+collectionExpressionMessage = "CollectionExpressionUnsupported: collection expressions are reserved for plan 166"++scalarOperatorTable :: [[Operator P Expr]]+scalarOperatorTable =+  [ [InfixL (op "*" *> located EMultiply)],+    [ InfixL (op "+" *> located EAdd),+      InfixL (op "-" *> located ESubtract),+      InfixL scalarArithmeticUnsupported+    ],+    [ InfixN (ECmp OpLe <$ op "<="),+      InfixN (ECmp OpGe <$ op ">="),+      InfixN (ECmp OpEq <$ op "=="),+      InfixN (ECmp OpNeq <$ op "!="),+      InfixN (ECmp OpLt <$ op "<"),+      InfixN (ECmp OpGt <$ op ">"),+      InfixN collectionOperatorUnsupported+    ],+    [InfixL (EAnd <$ op "&&")],+    [InfixL (EOr <$ op "||")]+  ]+  where+    op value = symbol value+    located constructor = do+      loc <- getLoc+      pure (constructor loc)+    scalarArithmeticUnsupported = do+      offset <- getOffset+      operator <- lexeme (oneOf ['/', '%'])+      failAt offset ("aggregate arithmetic operator '" <> [operator] <> "' is unsupported")+    collectionOperatorUnsupported = do+      offset <- getOffset+      _ <- try (keyword "not" *> keyword "in") <|> keyword "in"+      failAt offset collectionExpressionMessage++--------------------------------------------------------------------------------

@@ -0,0 +1,241 @@+-- | Contract, intake, emit, and publisher syntax.+module Keiro.Dsl.Parser.Integration+  ( pContract,+    pIntake,+    pEmit,+    pPublisher,+  )+where++import Keiro.Dsl.Grammar+import Keiro.Dsl.Parser.Core+import Text.Megaparsec++-- Integration contract (EP-4)+--------------------------------------------------------------------------------++pContract :: P ContractNode+pContract = do+  loc <- getLoc+  keyword "contract"+  nm <- ident+  _ <- symbol "{"+  keyword "schemaVersion"+  sv <- boundedDecimal+  keyword "discriminator"+  disc <- ident+  topics <- many pTopic+  events <- many pContractEvent+  _ <- symbol "}"+  pure+    ContractNode+      { ctrName = nm,+        ctrSchemaVersion = sv,+        ctrDiscriminator = disc,+        ctrTopics = topics,+        ctrEvents = events,+        ctrLoc = loc+      }+  where+    pTopic = do+      keyword "topic"+      alias <- ident+      t <- stringLit+      pure (alias, t)+    pContractEvent = do+      keyword "event"+      nm <- ident+      keyword "on"+      topicAlias <- ident+      fs <- braces (many pContractField)+      pure ContractEvent {ceName = nm, ceTopic = topicAlias, ceFields = fs}+    pContractField = do+      n <- ident+      _ <- symbol ":"+      ty <- pContractType+      _ <- optional (symbol ";")+      pure ContractField {cfName = n, cfType = ty}+    pContractType =+      choice+        [ CTypeId <$> (keyword "typeid" *> stringLit),+          CText <$ keyword "text",+          CInt <$ keyword "int"+        ]++pIntake :: P IntakeNode+pIntake = do+  loc <- getLoc+  keyword "intake"+  nm <- ident+  _ <- symbol "{"+  keyword "contract"+  ctr <- ident+  keyword "topic"+  tp <- ident+  keyword "accept"+  acc <- some ident+  binds <- many pBindRow+  keyword "dedupe"+  keyword "key"+  dk <- ident+  keyword "policy"+  dp <- ident+  persistence <-+    option InkPersistFull $+      keyword "persist"+        *> symbol "="+        *> choice+          [ InkPersistFull <$ keyword "full-envelope",+            InkPersistDedupeOnly <$ keyword "dedupe-only"+          ]+  dec <- pDecode+  disp <- pDisposition+  _ <- symbol "}"+  pure+    IntakeNode+      { inkName = nm,+        inkContract = ctr,+        inkTopic = tp,+        inkAccept = acc,+        inkBinds = binds,+        inkDedupeKey = dk,+        inkDedupePolicy = dp,+        inkPersist = persistence,+        inkDecode = dec,+        inkDisposition = disp,+        inkLoc = loc+      }+  where+    pBindRow = do+      keyword "bind"+      f <- ident+      keyword "from"+      src <- pWireSource+      req <- option False (True <$ keyword "required")+      xc <- option False (True <$ (keyword "cross-check" *> keyword "body"))+      pure BindRow {brField = f, brSource = src, brRequired = req, brCrossCheck = xc}+    pWireSource =+      choice+        [ SrcHeader <$> (keyword "header" *> stringLit),+          SrcKafkaKey <$ keyword "kafka-key",+          SrcKafkaCursor <$ keyword "kafka-cursor",+          SrcBody <$ keyword "body"+        ]+    pDecode = do+      keyword "decode"+      _ <- symbol "{"+      keyword "envelope"+      env <- pEnvelopePolicy+      keyword "body"+      strict <- (True <$ keyword "strict") <|> (False <$ keyword "lenient")+      keyword "schemaVersion"+      _ <- symbol "=="+      v <- boundedDecimal+      _ <- symbol "}"+      pure DecodeSpec {decEnvelope = env, decBodyStrict = strict, decBodySchemaVersion = v}+    pEnvelopePolicy = do+      a <- wireWord+      b <- wireWord+      pure (a <> " " <> b)+    pDisposition = do+      keyword "disposition"+      rows <- braces (many pDispositionRow)+      pure rows+    pDispositionRow = do+      loc <- getLoc+      o <- ident+      _ <- symbol "=>"+      act <- pInboxAction+      pure DispositionRow {drOutcome = o, drAction = act, drLoc = loc}+    pInboxAction =+      choice+        [ IAckOk <$ keyword "ackOk",+          IRetry <$> (keyword "retry" *> pWindow),+          IDeadLetter <$> (keyword "deadLetter" *> optional stringLit)+        ]++pEmit :: P EmitNode+pEmit = do+  loc <- getLoc+  keyword "emit"+  nm <- ident+  _ <- symbol "{"+  keyword "contract"+  ctr <- ident+  keyword "topic"+  tp <- ident+  keyword "source"+  src <- stringLit+  keyword "key"+  k <- ident+  keyword "map"+  disc <- ident+  (rows, skip) <- braces pMapRows+  keyword "messageId"+  mid <- pDerive+  keyword "idempotencyKey"+  idk <- pDerive+  _ <- symbol "}"+  pure+    EmitNode+      { emName = nm,+        emContract = ctr,+        emTopic = tp,+        emSource = src,+        emKey = k,+        emDiscriminant = disc,+        emMap = rows,+        emSkip = skip,+        emMessageId = mid,+        emIdempotencyKey = idk,+        emLoc = loc+      }+  where+    pMapRows = do+      rows <- many pMapRow+      skip <- option False (True <$ try (symbol "_" *> symbol "=>" *> keyword "skip"))+      pure (rows, skip)+    pMapRow = try $ do+      loc <- getLoc+      v <- stringLit+      _ <- symbol "=>"+      ev <- ident+      pure EmitMapRow {emrValue = v, emrEvent = ev, emrLoc = loc}+    pDerive = do+      keyword "derive"+      pfx <- optional stringLit+      keyword "hole"+      pure DeriveSpec {dsPrefix = pfx}++pPublisher :: P PublisherNode+pPublisher = do+  loc <- getLoc+  keyword "publisher"+  nm <- ident+  _ <- symbol "{"+  keyword "emit"+  em <- ident+  keyword "ordering"+  ord <- ident+  keyword "maxAttempts"+  ma <- boundedDecimal+  keyword "backoff"+  bk <- ident+  bw <- pWindow+  bm <- optional (keyword "max" *> symbol "=" *> pWindow)+  multiplier <- optional (keyword "multiplier" *> symbol "=" *> decimalText)+  keyword "outboxId"+  keyword "stable"+  keyword "from"+  obf <- ident+  _ <- symbol "}"+  pure+    PublisherNode+      { pubName = nm,+        pubEmit = em,+        pubOrdering = ord,+        pubMaxAttempts = ma,+        pubBackoff = BackoffSpec {boKind = bk, boWindow = bw, boMax = bm, boMultiplier = multiplier},+        pubOutboxField = obf,+        pubLoc = loc+      }

@@ -0,0 +1,323 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | Consumer-owned mapped and nominal type syntax.+module Keiro.Dsl.Parser.Mapped+  ( pMappedTopItem,+    pMappedTypeExpr,+    pUsingNominalBinding,+  )+where++import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Keiro.Dsl.Frontend.Internal (FrontendContext, frontendSupportsFeature)+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Syntax (SurfaceTopItem (..))+import Text.Megaparsec++-- Consumer-owned mapped and nominal types+--------------------------------------------------------------------------------++data MappedKind = MappedRecord | MappedEnum | MappedUnion++data MappedClause+  = MCHaskell HaskellSource+  | MCBinding Text+  | MCBindingVersion Text+  | MCCanonical Text+  | MCFixtures Text+  | MCInitial Text+  | MCCodec Text+  | MCCodecVersion Text+  | MCShape MappedShape++pMappedTopItem :: FrontendContext -> P SurfaceTopItem+pMappedTopItem context = do+  loc <- getLoc+  keyword "mapped"+  choice+    [ if frontendSupportsFeature context NominalBindingSyntax+        then SurfaceNominalScalar <$> pNominalScalarAfterMapped loc+        else do+          marker <- withOwnedSpan (try (keyword "nominal"))+          requireLanguageFeatureAt context NominalBindingSyntax (spanOf marker)+          fail "unreachable enabled nominal syntax in predecessor grammar",+      SurfaceMapped <$> pMappedStructural context loc,+      SurfaceMapped <$> pMappedOpaque loc+    ]++pMappedStructural :: FrontendContext -> Loc -> P MappedDecl+pMappedStructural context loc = do+  keyword "structural"+  kind <-+    choice+      [ MappedRecord <$ keyword "record",+        MappedEnum <$ keyword "enum",+        MappedUnion <$ keyword "union"+      ]+  name <- ident+  clauses <- braces (many (pStructuralClause context kind))+  hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses+  binding <- oneClause "binding" (\case MCBinding value -> Just value; _ -> Nothing) clauses+  bindingVersion <- oneClause "binding-version" (\case MCBindingVersion value -> Just value; _ -> Nothing) clauses+  canonical <- oneClause "canonical-type" (\case MCCanonical value -> Just value; _ -> Nothing) clauses+  fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses+  initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses+  shape <- requiredClause "wire" (\case MCShape value -> Just value; _ -> Nothing) clauses+  pure+    MappedStructural+      { msName = name,+        msHaskell = hs,+        msBinding = binding,+        msBindingVersion = bindingVersion,+        msCanonical = canonical,+        msFixtures = fixtures,+        msInitial = initial,+        msShape = shape,+        msLoc = loc+      }++pMappedOpaque :: Loc -> P MappedDecl+pMappedOpaque loc = do+  keyword "opaque"+  name <- ident+  clauses <- braces (many pOpaqueClause)+  hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses+  codec <- oneClause "codec" (\case MCCodec value -> Just value; _ -> Nothing) clauses+  version <- oneClause "version" (\case MCCodecVersion value -> Just value; _ -> Nothing) clauses+  fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses+  initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses+  pure+    MappedOpaque+      { moName = name,+        moHaskell = hs,+        moCodecId = codec,+        moCodecVersion = version,+        moFixtures = fixtures,+        moInitial = initial,+        moLoc = loc+      }++pNominalScalarAfterMapped :: Loc -> P NominalScalarDecl+pNominalScalarAfterMapped loc = do+  keyword "nominal"+  name <- ident+  _ <- symbol ":"+  representation <- ident+  binding <- pNominalBindingBlock loc+  pure+    NominalScalarDecl+      { nominalScalarName = name,+        nominalScalarRepresentation = representation,+        nominalScalarBinding = binding,+        nominalScalarLoc = loc+      }++pUsingNominalBinding :: P NominalBindingDecl+pUsingNominalBinding = do+  keyword "using"+  loc <- getLoc+  pNominalBindingBlock loc++pNominalBindingBlock :: Loc -> P NominalBindingDecl+pNominalBindingBlock loc = do+  clauses <- braces (many pNominalClause)+  hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses+  binding <- oneClause "binding" (\case MCBinding value -> Just value; _ -> Nothing) clauses+  bindingVersion <- oneClause "binding-version" (\case MCBindingVersion value -> Just value; _ -> Nothing) clauses+  canonical <- oneClause "canonical-type" (\case MCCanonical value -> Just value; _ -> Nothing) clauses+  fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses+  initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses+  pure+    NominalBindingDecl+      { nominalHaskell = hs,+        nominalBinding = binding,+        nominalBindingVersion = bindingVersion,+        nominalCanonicalType = canonical,+        nominalFixtures = fixtures,+        nominalInitial = initial,+        nominalLoc = loc+      }++pNominalClause :: P MappedClause+pNominalClause =+  choice+    [ MCHaskell <$> pHaskellSource,+      MCBindingVersion <$> pQuotedFact "binding-version",+      MCBinding <$> pQuotedFact "binding",+      MCCanonical <$> pQuotedFact "canonical-type",+      MCFixtures <$> pQuotedFact "fixtures",+      MCInitial <$> pQuotedFact "initial"+    ]++pStructuralClause :: FrontendContext -> MappedKind -> P MappedClause+pStructuralClause context kind =+  choice+    [ MCHaskell <$> pHaskellSource,+      MCBindingVersion <$> pQuotedFact "binding-version",+      MCBinding <$> pQuotedFact "binding",+      MCCanonical <$> pQuotedFact "canonical-type",+      MCFixtures <$> pQuotedFact "fixtures",+      MCInitial <$> pQuotedFact "initial",+      MCShape <$> pMappedShape context kind+    ]++pOpaqueClause :: P MappedClause+pOpaqueClause =+  choice+    [ MCHaskell <$> pHaskellSource,+      MCCodec <$> pQuotedFact "codec",+      MCCodecVersion <$> pQuotedFact "version",+      MCFixtures <$> pQuotedFact "fixtures",+      MCInitial <$> pQuotedFact "initial"+    ]++pHaskellSource :: P HaskellSource+pHaskellSource = do+  keyword "haskell"+  keyword "package"+  _ <- symbol "="+  packageName <- wireWord+  keyword "module"+  _ <- symbol "="+  moduleName <- pModulePrefix+  keyword "type"+  _ <- symbol "="+  typeName <- ident+  pure HaskellSource {hsPackage = packageName, hsModule = moduleName, hsType = typeName}++pQuotedFact :: Text -> P Text+pQuotedFact factName = keyword factName *> symbol "=" *> stringLit++pMappedShape :: FrontendContext -> MappedKind -> P MappedShape+pMappedShape context kind = do+  keyword "wire"+  case kind of+    MappedRecord -> do+      keyword "object"+      keyword "constructor"+      _ <- symbol "="+      constructor <- ident+      unknownFields <- pUnknownFieldsFact+      fields <- braces (many (pWireField context))+      pure (ShapeRecord constructor unknownFields fields)+    MappedEnum -> do+      keyword "string"+      ShapeEnum <$> braces (many pWireEnum)+    MappedUnion -> do+      keyword "tagged-object"+      keyword "tag"+      _ <- symbol "="+      tagField <- stringLit+      keyword "contents"+      _ <- symbol "="+      contentsField <- stringLit+      unknownFields <- pUnknownFieldsFact+      arms <- braces (many (pWireArm context))+      pure (ShapeUnion (TaggedObject tagField contentsField unknownFields) arms)++pUnknownFieldsFact :: P UnknownFields+pUnknownFieldsFact = do+  keyword "unknown-fields"+  _ <- symbol "="+  choice [RejectUnknown <$ keyword "reject", IgnoreUnknown <$ keyword "ignore"]++pWireField :: FrontendContext -> P WireField+pWireField context = do+  loc <- getLoc+  haskellName <- ident+  keyword "as"+  wireKey <- stringLit+  _ <- symbol ":"+  fieldType <- pMappedTypeExpr context+  presence <- choice [PRequired <$ keyword "required", POptional <$ keyword "optional"]+  onMissing <- optional (keyword "on-missing" *> symbol "=" *> pOnMissing)+  pure+    WireField+      { wfHaskell = haskellName,+        wfKey = wireKey,+        wfType = fieldType,+        wfPresence = presence,+        wfOnMissing = onMissing,+        wfLoc = loc+      }++pWireEnum :: P WireEnum+pWireEnum = do+  loc <- getLoc+  constructor <- ident+  keyword "as"+  wireTag <- stringLit+  pure WireEnum {weCtor = constructor, weTag = wireTag, weLoc = loc}++pWireArm :: FrontendContext -> P WireArm+pWireArm context = do+  loc <- getLoc+  constructor <- ident+  keyword "as"+  wireTag <- stringLit+  payload <- optional (symbol ":" *> pMappedTypeExpr context)+  pure WireArm {waCtor = constructor, waTag = wireTag, waPayload = payload, waLoc = loc}++pMappedTypeExpr :: FrontendContext -> P TypeExpr+pMappedTypeExpr context =+  choice+    [ TOptional <$> (keyword "Optional" *> pTypeArgument),+      TList <$> (keyword "List" *> pTypeArgument),+      TMap <$> (keyword "Map" *> pTypeArgument),+      TText <$ keyword "Text",+      TInt <$ keyword "Int",+      TInteger <$ languageFeatureKeyword context IntegerScalarSyntax "Integer",+      TBool <$ keyword "Bool",+      TNatural <$ keyword "Natural",+      TTime <$ (keyword "Time" <|> keyword "UTCTime"),+      TJson <$ keyword "Json",+      TRef <$> ident+    ]+  where+    pTypeArgument = parens (pMappedTypeExpr context) <|> pTypeAtom+    pTypeAtom =+      choice+        [ TText <$ keyword "Text",+          TInt <$ keyword "Int",+          TInteger <$ languageFeatureKeyword context IntegerScalarSyntax "Integer",+          TBool <$ keyword "Bool",+          TNatural <$ keyword "Natural",+          TTime <$ (keyword "Time" <|> keyword "UTCTime"),+          TJson <$ keyword "Json",+          TRef <$> ident+        ]++languageFeatureKeyword :: FrontendContext -> LanguageFeature -> Text -> P ()+languageFeatureKeyword context feature spelling = do+  marker <- withOwnedSpan (keyword spelling)+  requireLanguageFeatureAt context feature (spanOf marker)++pOnMissing :: P OnMissing+pOnMissing =+  choice+    [ OmNull <$ keyword "null",+      OmEmptyList <$ (symbol "[" *> symbol "]"),+      OmEmptyMap <$ (symbol "{" *> symbol "}"),+      OmBool True <$ keyword "true",+      OmBool False <$ keyword "false",+      OmText <$> stringLit,+      OmInt <$> integerLiteral,+      OmCtor <$> ident+    ]++oneClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P (Maybe a)+oneClause clauseName select clauses =+  case mapMaybe select clauses of+    [] -> pure Nothing+    [value] -> pure (Just value)+    _ -> fail ("duplicate " <> clauseName <> " clause in mapped declaration")++requiredClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P a+requiredClause clauseName select clauses = do+  found <- oneClause clauseName select clauses+  maybe (fail ("missing " <> clauseName <> " clause in mapped structural declaration")) pure found++--------------------------------------------------------------------------------

@@ -0,0 +1,117 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | Released-language preamble recognition and source selection.+module Keiro.Dsl.Parser.Preamble+  ( contextualDiagnostic,+    pDeclaredPreamble,+    selectSourceLanguage,+  )+where++import Data.Char (isAscii, isDigit)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Read qualified as TR+import Keiro.Dsl.Frontend.Internal+import Keiro.Dsl.Grammar (Loc (..))+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Source+import Numeric.Natural (Natural)+import Text.Megaparsec+import Text.Megaparsec.Char (char)++contextualDiagnostic :: FilePath -> SourceLanguage -> ContextualParseFailure -> SourceLanguageDiagnostic+contextualDiagnostic src sourceLanguage contextual =+  SourceLanguageDiagnostic+    { sourceLanguageErrorCode = code,+      sourceLanguageSource = src,+      sourceLanguageLoc = Loc line,+      sourceLanguageToken = case code of+        LanguageFeatureRequiresVersion -> Just (languageVersionText effectiveVersion)+        _ -> Nothing,+      sourceLanguageDeclaredVersion = case code of+        LanguageFeatureRequiresVersion -> Just effectiveVersion+        _ -> Nothing,+      sourceLanguageSupportedVersions = supportedLanguageVersions+    }+  where+    code = contextualFailureCode contextual+    SourceSpan {start = SourcePoint {line}} = contextualFailureSpan contextual+    effectiveVersion = effectiveLanguageVersion sourceLanguage++-- | Consume a preamble already validated by 'selectSourceLanguage'. This+-- parser is also reused at grammar boundaries to recognize only complete+-- preamble syntax, never a nested identifier whose spelling is @language@.+pDeclaredPreamble :: P ()+pDeclaredPreamble = do+  keyword "language"+  keyword "keiro-dsl"+  _ <- lexeme (some asciiDigit)+  pure ()++-- | The source-selection pass inspects only the first grammar clause after+-- leading whitespace and comments. Body lines are left entirely to+-- 'pSurfaceSpec'.+data InitialLanguageClause = InitialLanguageClause+  { initialLanguageSpan :: !SourceSpan,+    initialLanguageText :: !Text+  }++selectSourceLanguage :: FilePath -> Text -> Either FrontendFailure SourceLanguage+selectSourceLanguage src input = do+  initialClause <- case runParser pInitialLanguageClause src input of+    Left bundle ->+      Left+        ( frontendFailureFromBody+            SourceSelectionPhase+            (bundleFailureSpan bundle)+            (bundleMessage bundle)+            (bundleExpected bundle)+            (BodyGrammarFailure (T.pack (errorBundlePretty bundle)))+        )+    Right value -> Right value+  case initialClause of+    Nothing -> Right LegacyUnversioned+    Just languageClause -> do+      version <- parsePreamble languageClause+      case lookupLanguageDefinition version of+        Nothing -> Left (sourceFailure UnsupportedLanguageVersion languageClause (Just (languageVersionText version)) (Just version))+        Just _ -> Right (DeclaredLanguage version (Loc (startLine (initialLanguageSpan languageClause))))+  where+    sourceFailure code line tokenText declared =+      frontendFailureFromSourceDiagnostic+        SourceSelectionPhase+        (initialLanguageSpan line)+        Nothing+        SourceLanguageDiagnostic+          { sourceLanguageErrorCode = code,+            sourceLanguageSource = src,+            sourceLanguageLoc = Loc (startLine (initialLanguageSpan line)),+            sourceLanguageToken = tokenText,+            sourceLanguageDeclaredVersion = declared,+            sourceLanguageSupportedVersions = supportedLanguageVersions+          }++    parsePreamble line = case T.words (initialLanguageText line) of+      ["language", "keiro-dsl", tokenText]+        | T.all (\c -> isAscii c && isDigit c) tokenText && not (T.null tokenText) ->+            case TR.decimal tokenText :: Either String (Natural, Text) of+              Right (value, "") -> case languageVersion value of+                Just version -> Right version+                Nothing -> invalid line tokenText+              _ -> invalid line tokenText+      wordsFound -> invalid line (T.unwords wordsFound)++    invalid line tokenText =+      Left (sourceFailure InvalidLanguageVersion line (Just tokenText) Nothing)++pInitialLanguageClause :: P (Maybe InitialLanguageClause)+pInitialLanguageClause = sc *> optional pLanguageClause+  where+    pLanguageClause = do+      _ <- lookAhead (chunk "language" *> notFollowedBy (identChar <|> (char '-' *> identChar)))+      locatedLine <- withOwnedSpan (takeWhileP (Just "language preamble") (\c -> c /= '\n' && c /= '\r'))+      let rawLine = locatedValue locatedLine+      let content = T.strip (T.takeWhile (/= '#') rawLine)+      pure InitialLanguageClause {initialLanguageSpan = spanOf locatedLine, initialLanguageText = content}

@@ -0,0 +1,147 @@+-- | Workqueue and pgmq-dispatch syntax.+module Keiro.Dsl.Parser.Queue+  ( pWorkqueue,+    pPgmqDispatch,+  )+where++import Keiro.Dsl.Grammar+import Keiro.Dsl.Parser.Core+import Text.Megaparsec++pWorkqueue :: P WorkqueueNode+pWorkqueue = do+  loc <- getLoc+  keyword "workqueue"+  nm <- ident+  _ <- symbol "{"+  keyword "queue"+  _ <- symbol "logical" *> symbol "="+  logical <- stringLit+  keyword "derive"+  _ <- symbol "physical" *> symbol "="+  phys <- stringLit+  _ <- symbol "dlq" *> symbol "="+  dlqName <- stringLit+  _ <- symbol "table" *> symbol "="+  tbl <- stringLit+  ordering <- option WqUnordered pOrdering+  groupKey <- optional pGroupKey+  provision <- option WqStandard pProvision+  keyword "payload"+  pn <- ident+  fields <- braces (many pWqField)+  keyword "retry"+  _ <- symbol "maxRetries" *> symbol "="+  mr <- boundedDecimal+  _ <- symbol "delay" *> symbol "="+  dl <- pWindow+  _ <- symbol "dlq" *> symbol "="+  dlqOn <- (True <$ keyword "on") <|> (False <$ keyword "off")+  keyword "disposition"+  disp <- braces (many pWqDispRow)+  _ <- symbol "}"+  pure+    WorkqueueNode+      { wqName = nm,+        wqLogical = logical,+        wqPhysical = phys,+        wqDlq = dlqName,+        wqTable = tbl,+        wqOrdering = ordering,+        wqGroupKey = groupKey,+        wqProvision = provision,+        wqPayloadName = pn,+        wqPayload = fields,+        wqMaxRetries = mr,+        wqDelay = dl,+        wqDlqOn = dlqOn,+        wqDisposition = disp,+        wqLoc = loc+      }+  where+    pOrdering = do+      _ <- symbol "ordering"+      choice+        [ WqUnordered <$ symbol "unordered",+          WqFifoThroughput <$ symbol "fifo-throughput",+          WqFifoRoundRobin <$ symbol "fifo-roundrobin"+        ]+    pGroupKey = do+      _ <- symbol "group" *> symbol "key" *> symbol "from"+      field <- ident+      _ <- symbol "via"+      via <- ident+      fixture <- optional (symbol "fixture" *> stringLit)+      pure WqGroupKey {gkField = field, gkVia = via, gkFixture = fixture}+    pProvision = do+      _ <- symbol "provision"+      choice+        [ WqStandard <$ symbol "standard",+          WqUnlogged <$ symbol "unlogged",+          do+            _ <- symbol "partitioned" *> symbol "("+            _ <- symbol "interval" *> symbol "="+            interval <- stringLit+            _ <- symbol "," *> symbol "retention" *> symbol "="+            retention <- stringLit+            _ <- symbol ")"+            pure (WqPartitioned interval retention)+        ]+    pWqField = do+      n <- ident+      _ <- symbol "->"+      w <- stringLit+      ty <- ident+      req <- option False (True <$ keyword "required")+      pure WqField {wqfName = n, wqfWire = w, wqfType = ty, wqfRequired = req}+    pWqDispRow = do+      loc <- getLoc+      o <- ident+      _ <- symbol "->"+      act <- choice [IAckOk <$ keyword "ackOk", IRetry <$> (keyword "retry" *> pWindow), IDeadLetter <$> (keyword "deadLetter" *> optional stringLit)]+      pure WqDispRow {wqdOutcome = o, wqdAction = act, wqdLoc = loc}++pPgmqDispatch :: P PgmqDispatchNode+pPgmqDispatch = do+  loc <- getLoc+  keyword "dispatch"+  nm <- ident+  _ <- symbol "{"+  keyword "source"+  _ <- symbol "readModel" *> symbol "="+  srm <- ident+  _ <- symbol "key" *> symbol "="+  sk <- ident+  keyword "fanout"+  _ <- symbol "body" *> symbol "="+  fb <- ident+  keyword "dedup"+  _ <- symbol "key" *> symbol "="+  dk <- ident+  _ <- keyword "seenIn" *> symbol "readModel" *> symbol "="+  drm <- ident+  _ <- symbol "field" *> symbol "="+  drmf <- ident+  _ <- keyword "seenIn" *> symbol "queue" *> symbol "="+  dq <- ident+  _ <- symbol "field" *> symbol "="+  dqf <- ident+  keyword "enqueue"+  _ <- symbol "to" *> symbol "="+  enq <- ident+  _ <- symbol "}"+  pure+    PgmqDispatchNode+      { pdName = nm,+        pdSourceReadModel = srm,+        pdSourceKey = sk,+        pdFanoutBody = fb,+        pdDedupKey = dk,+        pdDedupReadModel = drm,+        pdDedupReadModelField = drmf,+        pdDedupQueue = dq,+        pdDedupQueueField = dqf,+        pdEnqueueTo = enq,+        pdLoc = loc+      }

@@ -0,0 +1,60 @@+-- | Read-model syntax.+module Keiro.Dsl.Parser.ReadModel+  ( pReadModel,+  )+where++import Keiro.Dsl.Grammar+import Keiro.Dsl.Parser.Core+import Text.Megaparsec++pReadModel :: P ReadModelNode+pReadModel = do+  loc <- getLoc+  keyword "readmodel"+  name <- ident+  _ <- symbol "{"+  _ <- symbol "table" *> symbol "="+  table <- stringLit+  _ <- symbol "schema" *> symbol "="+  schema <- stringLit+  _ <- symbol "columns"+  columns <- braces (many pColumn)+  _ <- symbol "version" *> symbol "="+  version <- boundedDecimal+  _ <- symbol "shape" *> symbol "="+  shape <- stringLit+  _ <- symbol "consistency" *> symbol "="+  consistency <- pConsistency+  scope <- optional (symbol "scope" *> symbol "=" *> pScope)+  _ <- symbol "feed" *> symbol "="+  feed <- pFeed+  subscription <- optional (symbol "subscription" *> symbol "=" *> stringLit)+  _ <- symbol "}"+  pure+    ReadModelNode+      { rmName = name,+        rmTable = table,+        rmSchema = schema,+        rmColumns = columns,+        rmVersion = version,+        rmShape = shape,+        rmConsistency = consistency,+        rmScope = scope,+        rmFeed = feed,+        rmSubscription = subscription,+        rmLoc = loc+      }+  where+    pColumn =+      RmColumn+        <$> wireWord+        <*> ident+        <*> option False (True <$ keyword "required")+    pConsistency = choice [Strong <$ keyword "Strong", Eventual <$ keyword "Eventual"]+    pScope =+      choice+        [ RmEntireLog <$ keyword "entire-log",+          RmCategory <$> (keyword "category" *> stringLit)+        ]+    pFeed = choice [RmInline <$ keyword "inline", RmSubscription <$ keyword "subscription"]

@@ -0,0 +1,135 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | Durable workflow and operation syntax.+module Keiro.Dsl.Parser.Workflow+  ( pWorkflow,+    pOperation,+  )+where++import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.Parser.Core+import Text.Megaparsec++pWorkflow :: P WorkflowNode+pWorkflow = do+  loc <- getLoc+  keyword "workflow"+  wid <- ident+  keyword "name"+  nm <- stringLit+  keyword "in"+  inTy <- ident+  inFields <- option [] (braces (many pField))+  keyword "out"+  outTy <- ident+  keyword "id"+  keyword "from"+  keyword "input"+  idField <- optional (symbol "." *> ident)+  keyword "via"+  idVia <- ident+  keyword "body"+  body <- many pWfBodyItem+  pure+    WorkflowNode+      { wfId = wid,+        wfStable = nm,+        wfInput = inTy,+        wfInputFields = inFields,+        wfOutput = outTy,+        wfIdField = idField,+        wfIdVia = idVia,+        wfBody = body,+        wfLoc = loc+      }+  where+    pWfBodyItem =+      choice+        [ do+            loc <- getLoc+            WfStep <$> (keyword "step" *> wireWord) <*> (symbol "->" *> ident) <*> pure loc,+          do+            loc <- getLoc+            WfAwait <$> (keyword "await" *> wireWord) <*> (symbol "->" *> ident) <*> pure loc,+          do+            loc <- getLoc+            WfSleep <$> (keyword "sleep" *> wireWord) <*> (keyword "after" *> ident) <*> pure loc,+          do+            loc <- getLoc+            WfChild+              <$> (keyword "child" *> wireWord)+              <*> (keyword "id" *> keyword "input" *> keyword "via" *> ident)+              <*> (symbol "->" *> ident)+              <*> pure loc,+          do+            loc <- getLoc+            WfPatch+              <$> (keyword "patch" *> patchIdWord)+              <*> braces (many pWfBodyItem)+              <*> pure loc,+          do+            loc <- getLoc+            WfContinueAsNew <$> (keyword "continueAsNew" *> ident) <*> pure loc+        ]++pOperation :: P OperationNode+pOperation = do+  loc <- getLoc+  keyword "operation"+  nm <- ident+  shape <-+    choice+      [ pCommandOp,+        pQueryOp,+        pSignalOp,+        pRunOp+      ]+  pure OperationNode {opName = nm, opShape = shape, opLoc = loc}+  where+    pCommandOp = do+      keyword "command"+      keyword "on"+      agg <- ident+      _ <- keyword "stream" *> keyword "from"+      sf <- ident+      keyword "via"+      sv <- ident+      proj <- option [] (keyword "project" *> brackets (many ident))+      pure (CommandOp agg sf sv proj)+    pQueryOp = do+      keyword "query"+      rm <- ident+      keyword "input"+      inp <- ident+      keyword "result"+      res <- pTypeExpr+      cons <- option "Strong" (keyword "consistency" *> ident)+      pure (QueryOp rm inp res cons)+    pSignalOp = do+      keyword "signal"+      lbl <- wireWord+      keyword "of"+      wf <- ident+      _ <- keyword "key" *> keyword "from"+      kf <- ident+      keyword "via"+      kv <- ident+      keyword "value"+      val <- ident+      pure (SignalOp lbl wf kf kv val)+    pRunOp = do+      keyword "run"+      wf <- ident+      keyword "input"+      inp <- ident+      _ <- keyword "outcome" *> symbol "->"+      oc <- ident+      pure (RunOp wf inp oc)+    -- A result type expression, possibly multi-word like @Maybe TransferDecision@.+    pTypeExpr = do+      ws <- some ident+      pure (T.unwords ws)++--------------------------------------------------------------------------------

@@ -28,6 +28,7 @@   ( LanguageVersion,     ParsedSource (..),     SourceLanguage (..),+    definitionRuntimeSemantics,     effectiveLanguageVersion,     languageVersion,     languageVersionNumber,@@ -76,14 +77,11 @@ -- semantics a compile-visible registry change. effectiveLanguageContractForVersion :: LanguageVersion -> Maybe EffectiveLanguageContract effectiveLanguageContractForVersion version = do-  _ <- lookupLanguageDefinition version+  definition <- lookupLanguageDefinition version   pure     EffectiveLanguageContract       { effectiveContractLanguageVersion = version,-        effectiveRuntimeSemantics =-          if languageVersionNumber version >= 3-            then "keiro-dsl/runtime-semantics/2"-            else "keiro-dsl/runtime-semantics/1"+        effectiveRuntimeSemantics = definitionRuntimeSemantics definition       }  -- | Fold/replay discriminator for runtime semantics newer than the historical

@@ -0,0 +1,76 @@+{-# LANGUAGE NoFieldSelectors #-}++-- | Source locations used by the Keiro language frontend.+--+-- Offsets count tokens in the parsed 'Text' stream. Spans are half-open: the+-- end point is immediately after the final token owned by a construct.+module Keiro.Dsl.Source+  ( SourcePoint (..),+    mkSourcePoint,+    SourceSpan (..),+    mkSourceSpan,+    validSourceSpan,+    startLine,+    Located (..),+    mapLocated,+  )+where++import GHC.Generics (Generic)+import Prelude hiding (span)++-- | An exact position in a parsed source.+data SourcePoint = SourcePoint+  { offset :: !Int,+    line :: !Int,+    column :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | Construct a non-negative offset with one-based line and column values.+mkSourcePoint :: Int -> Int -> Int -> Maybe SourcePoint+mkSourcePoint offset line column+  | offset < 0 = Nothing+  | line < 1 = Nothing+  | column < 1 = Nothing+  | otherwise = Just SourcePoint {offset, line, column}++-- | A half-open source interval.+data SourceSpan = SourceSpan+  { source :: !FilePath,+    start :: !SourcePoint,+    end :: !SourcePoint+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | Construct a span whose end does not precede its start.+mkSourceSpan :: FilePath -> SourcePoint -> SourcePoint -> Maybe SourceSpan+mkSourceSpan source start end+  | validPoints start end = Just SourceSpan {source, start, end}+  | otherwise = Nothing++-- | Check the ordering invariant even for a value built with the public+-- constructor.+validSourceSpan :: SourceSpan -> Bool+validSourceSpan SourceSpan {start, end} = validPoints start end++-- | Project the one-based starting line used by the legacy semantic 'Loc'.+startLine :: SourceSpan -> Int+startLine SourceSpan {start = SourcePoint {line}} = line++-- | A value together with the exact source syntax that owns it.+data Located a = Located+  { span :: !SourceSpan,+    value :: !a+  }+  deriving stock (Eq, Ord, Show, Functor, Generic)++mapLocated :: (a -> b) -> Located a -> Located b+mapLocated f Located {span, value} = Located {span, value = f value}++validPoints :: SourcePoint -> SourcePoint -> Bool+validPoints+  SourcePoint {offset = startOffset, line = startLineNumber, column = startColumn}+  SourcePoint {offset = endOffset, line = endLineNumber, column = endColumn} =+    startOffset <= endOffset+      && (startLineNumber, startColumn) <= (endLineNumber, endColumn)

@@ -0,0 +1,69 @@+{-# LANGUAGE NoFieldSelectors #-}++-- | Located, non-lossless surface syntax for a Keiro source document.+--+-- The surface layer preserves document order and source ownership while+-- deliberately omitting comments and whitespace. Semantic consumers should+-- use 'Keiro.Dsl.Frontend.lowerSurfaceSource' rather than depending on these+-- types directly.+module Keiro.Dsl.Syntax+  ( SurfaceSource (..),+    SurfaceSpec (..),+    SurfaceTopItem (..),+    SurfaceElement (..),+  )+where++import Data.Text (Text)+import GHC.Generics (Generic)+import Keiro.Dsl.Grammar+  ( EnumDecl,+    Expr,+    IdDecl,+    MappedDecl,+    Node,+    NominalScalarDecl,+    Placement,+    RuleDecl,+  )+import Keiro.Dsl.LanguageVersion (SourceLanguage)+import Keiro.Dsl.Source (Located)++-- | One parsed source with its selected released language contract.+data SurfaceSource = SurfaceSource+  { source :: !FilePath,+    language :: !SourceLanguage,+    preamble :: !(Maybe (Located SourceLanguage)),+    spec :: !(Located SurfaceSpec)+  }+  deriving stock (Eq, Show, Generic)++-- | Document-level syntax before declarations are normalized into grouped+-- semantic lists.+data SurfaceSpec = SurfaceSpec+  { context :: !(Located Text),+    moduleRoot :: !(Maybe (Located Text)),+    layout :: !(Maybe (Located Placement)),+    items :: ![Located SurfaceTopItem],+    elements :: ![Located SurfaceElement]+  }+  deriving stock (Eq, Show, Generic)++-- | A source-ordered top-level declaration or runtime node. Existing grammar+-- values are reused where parsing does not erase a syntax distinction.+data SurfaceTopItem+  = SurfaceId !IdDecl+  | SurfaceEnum !EnumDecl+  | SurfaceRule !RuleDecl+  | SurfaceNominalScalar !NominalScalarDecl+  | SurfaceMapped !MappedDecl+  | SurfaceNode !Node+  deriving stock (Eq, Show, Generic)++-- | Nested syntax whose exact ownership is required before semantic lowering.+-- The set grows with grammar-module extraction; semantic leaf values are+-- reused when parsing does not erase a distinction.+data SurfaceElement+  = SurfaceField !Text+  | SurfaceExpression !Expr+  deriving stock (Eq, Show, Generic)

@@ -0,0 +1,468 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- | The executable compatibility oracle for the released keiro-dsl-0.7.0.0+-- language frontend. The checked JSON is deliberately data, not an update mode:+-- a behavior change must produce a reviewed manifest diff.+module Keiro.Dsl.FrontendCompatibility+  ( SourceExpectation (..),+    WorkspaceExpectation (..),+    CompatibilityManifest (..),+    diagnosticGoldens,+    frontendCompatibilitySpec,+    observeSource,+    observeWorkspace,+    readCompatibilityManifest,+    readRepoText,+    releasedFrontendEntryPoints,+    sourceFixturePaths,+    workspaceFixturePaths,+  )+where++import Control.Monad (filterM, forM, forM_)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))+import Data.Aeson qualified as Aeson+import Data.List (sort)+import Data.List.NonEmpty qualified as NE+import Data.Maybe (listToMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Keiro.Dsl.FrontendPublicApiProbe (apiProbe)+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser (parseSource)+import Keiro.Dsl.PrettyPrint (renderSource)+import Keiro.Dsl.SemanticContract (checkedSource)+import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateService)+import Keiro.Dsl.Workspace+import Numeric.Natural (Natural)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.Environment (lookupEnv)+import System.FilePath (takeDirectory, takeExtension, (</>))+import Test.Hspec+import Text.Read (readMaybe)++data SourceExpectation = SourceExpectation+  { sourcePath :: !FilePath,+    sourceForm :: !Text,+    sourceDeclaredVersion :: !(Maybe Natural),+    sourceEffectiveVersion :: !(Maybe Natural),+    sourceResult :: !Text,+    sourceFailureClass :: !(Maybe Text),+    sourceDiagnosticCode :: !(Maybe Text)+  }+  deriving stock (Eq, Show)++instance FromJSON SourceExpectation where+  parseJSON = withObject "SourceExpectation" $ \fields ->+    SourceExpectation+      <$> fields .: "path"+      <*> fields .: "sourceForm"+      <*> fields .:? "declaredVersion"+      <*> fields .:? "effectiveVersion"+      <*> fields .: "result"+      <*> fields .:? "failureClass"+      <*> fields .:? "diagnosticCode"++instance ToJSON SourceExpectation where+  toJSON row =+    object+      [ "path" .= sourcePath row,+        "sourceForm" .= sourceForm row,+        "declaredVersion" .= sourceDeclaredVersion row,+        "effectiveVersion" .= sourceEffectiveVersion row,+        "result" .= sourceResult row,+        "failureClass" .= sourceFailureClass row,+        "diagnosticCode" .= sourceDiagnosticCode row+      ]++data WorkspaceExpectation = WorkspaceExpectation+  { workspacePath :: !FilePath,+    workspaceResult :: !Text,+    workspaceFailureClass :: !(Maybe Text),+    workspaceDiagnosticCode :: !(Maybe Text)+  }+  deriving stock (Eq, Show)++instance FromJSON WorkspaceExpectation where+  parseJSON = withObject "WorkspaceExpectation" $ \fields ->+    WorkspaceExpectation+      <$> fields .: "path"+      <*> fields .: "result"+      <*> fields .:? "failureClass"+      <*> fields .:? "diagnosticCode"++instance ToJSON WorkspaceExpectation where+  toJSON row =+    object+      [ "path" .= workspacePath row,+        "result" .= workspaceResult row,+        "failureClass" .= workspaceFailureClass row,+        "diagnosticCode" .= workspaceDiagnosticCode row+      ]++data CompatibilityManifest = CompatibilityManifest+  { manifestSchema :: !Text,+    manifestRelease :: !Text,+    manifestEntryPoints :: ![Text],+    manifestSources :: ![SourceExpectation],+    manifestWorkspaces :: ![WorkspaceExpectation]+  }+  deriving stock (Eq, Show)++instance FromJSON CompatibilityManifest where+  parseJSON = withObject "CompatibilityManifest" $ \fields ->+    CompatibilityManifest+      <$> fields .: "schema"+      <*> fields .: "release"+      <*> fields .: "entryPoints"+      <*> fields .: "sources"+      <*> fields .: "workspaces"++instance ToJSON CompatibilityManifest where+  toJSON manifest =+    object+      [ "schema" .= manifestSchema manifest,+        "release" .= manifestRelease manifest,+        "entryPoints" .= manifestEntryPoints manifest,+        "sources" .= manifestSources manifest,+        "workspaces" .= manifestWorkspaces manifest+      ]++frontendCompatibilitySpec :: SpecWith ()+frontendCompatibilitySpec = describe "frontend 0.7 compatibility" $ do+  it "decodes the released manifest and classifies every checked-in frontend fixture" $ do+    manifest <- readManifest+    manifestSchema manifest `shouldBe` "keiro-dsl/frontend-compatibility/1"+    manifestRelease manifest `shouldBe` "0.7.0.0"+    manifestEntryPoints manifest `shouldBe` releasedFrontendEntryPoints+    sources <- sourceFixturePaths+    workspaces <- workspaceFixturePaths+    map sourcePath (manifestSources manifest) `shouldBe` sources+    map workspacePath (manifestWorkspaces manifest) `shouldBe` workspaces++  it "preserves every source outcome, released contract, and accepted canonical round trip" $ do+    manifest <- readManifest+    forM_ (manifestSources manifest) $ \expected -> do+      actual <- observeSource (sourcePath expected)+      actual `shouldBe` expected+      whenAccepted expected $ do+        source <- readRepoText (sourcePath expected)+        case parseSource (sourcePath expected) source of+          Left failure -> expectationFailure (show failure)+          Right parsed -> case parseSource (sourcePath expected) (renderSource parsed) of+            Left failure -> expectationFailure (show failure)+            Right reparsed -> do+              parsedSpec reparsed `shouldBe` parsedSpec parsed+              effectiveLanguageVersion (parsedSourceLanguage reparsed)+                `shouldBe` effectiveLanguageVersion (parsedSourceLanguage parsed)+              sourceFormText (parsedSourceLanguage reparsed)+                `shouldBe` sourceFormText (parsedSourceLanguage parsed)++  it "preserves every workspace composition outcome and member-attribution code" $ do+    manifest <- readManifest+    forM_ (manifestWorkspaces manifest) $ \expected ->+      observeWorkspace (workspacePath expected) `shouldReturn` expected++  it "keeps direct parsing and representative one-member workspaces semantically identical" $ do+    let examples =+          [ ("legacy.keiro", "context parity\n"),+            ("v1.keiro", "language keiro-dsl 1\ncontext parity\n"),+            ("v2.keiro", "language keiro-dsl 2\ncontext parity\n"),+            ("v3.keiro", "language keiro-dsl 3\ncontext parity\n")+          ]+    forM_ examples $ \(path, source) -> case parseSource path source of+      Left failure -> expectationFailure (show failure)+      Right parsed -> do+        let workspace = oneMemberParsedWorkspace path parsed+        wsMergedSpec workspace `shouldBe` parsedSpec parsed+        checkWorkspace workspace `shouldBe` []++  it "renders curated source, grammar, semantic, and workspace failures byte-for-byte" $+    forM_ diagnosticGoldens $ \(name, renderActual) -> do+      expected <- readRepoText (diagnosticRoot </> name)+      actual <- renderActual+      actual `shouldBe` expected++  it "keeps the released parser, renderer, and representative selector signatures compiling" $+    apiProbe `shouldBe` ()++whenAccepted :: SourceExpectation -> IO () -> IO ()+whenAccepted row action+  | sourceResult row == "accept" = action+  | otherwise = pure ()++observeSource :: FilePath -> IO SourceExpectation+observeSource path = do+  source <- readRepoText path+  let (headerForm, headerVersion) = sourceHeader source+      base result failureClass diagnostic effective =+        SourceExpectation+          { sourcePath = path,+            sourceForm = headerForm,+            sourceDeclaredVersion = headerVersion,+            sourceEffectiveVersion = effective,+            sourceResult = result,+            sourceFailureClass = failureClass,+            sourceDiagnosticCode = diagnostic+          }+  pure $ case parseSource path source of+    Left (SourceLanguageFailure diagnostic) ->+      base+        "reject"+        (Just "source-language")+        (Just (sourceLanguageErrorCodeText (sourceLanguageErrorCode diagnostic)))+        (languageVersionNumber <$> sourceLanguageDeclaredVersion diagnostic)+    Left (BodyGrammarFailure _) ->+      base "reject" (Just "body-grammar") Nothing (supportedHeaderVersion headerVersion)+    Right parsed ->+      let sourceLanguage = parsedSourceLanguage parsed+          effective = Just (languageVersionNumber (effectiveLanguageVersion sourceLanguage))+          errors = filter ((== Error) . severity) (validateService (checkedSource parsed))+       in case errors of+            diagnostic : _ -> base "reject" (Just "semantic") (Just (T.pack (show (code diagnostic)))) effective+            [] -> base "accept" Nothing Nothing effective++observeWorkspace :: FilePath -> IO WorkspaceExpectation+observeWorkspace path = do+  resolved <- resolveRepoPath path+  loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) path+  pure $ case loaded of+    Left (WorkspaceManifestUnreadable _) -> rejected "manifest-unreadable" Nothing+    Left (WorkspaceManifestUnparseable _) -> rejected "manifest-grammar" Nothing+    Left (WorkspaceRefused diagnostics) ->+      rejected "composition" (Just (T.pack (show (wdCode (NE.head diagnostics)))))+    Right workspace -> case filter ((== Error) . wdSeverity) (checkWorkspace workspace) of+      diagnostic : _ -> rejected "semantic" (Just (T.pack (show (wdCode diagnostic))))+      [] -> WorkspaceExpectation path "accept" Nothing Nothing+  where+    rejected failureClass diagnostic = WorkspaceExpectation path "reject" (Just failureClass) diagnostic++sourceHeader :: Text -> (Text, Maybe Natural)+sourceHeader source = case firstSignificantLine source of+  Just lineText+    | Just token <- T.stripPrefix "language keiro-dsl " lineText ->+        ("declared", readMaybe (T.unpack (T.strip token)))+  _ -> ("legacy-unversioned", Nothing)++firstSignificantLine :: Text -> Maybe Text+firstSignificantLine =+  listToMaybe+    . filter (\lineText -> not (T.null lineText) && not ("#" `T.isPrefixOf` lineText))+    . map T.strip+    . T.lines++supportedHeaderVersion :: Maybe Natural -> Maybe Natural+supportedHeaderVersion raw = do+  number <- raw+  version <- languageVersion number+  _ <- lookupLanguageDefinition version+  pure number++readManifest :: IO CompatibilityManifest+readManifest = do+  path <- resolveRepoPath manifestPath+  decoded <- Aeson.eitherDecodeFileStrict' path+  case decoded of+    Left problem -> expectationFailure problem >> fail "invalid frontend compatibility manifest"+    Right manifest -> pure manifest++readCompatibilityManifest :: IO CompatibilityManifest+readCompatibilityManifest = readManifest++sourceFixturePaths :: IO [FilePath]+sourceFixturePaths = fixturePaths ".keiro"++workspaceFixturePaths :: IO [FilePath]+workspaceFixturePaths = fixturePaths ".keiro-workspace"++fixturePaths :: String -> IO [FilePath]+fixturePaths extension = do+  fixtureRoot <- resolveRepoDirectory "keiro-dsl/test/fixtures"+  relative <- walk fixtureRoot ""+  pure . sort $ ["keiro-dsl/test/fixtures" </> path | path <- relative, takeExtension path == extension]+  where+    walk root relative = do+      entries <- sort <$> listDirectory (root </> relative)+      fmap concat . forM entries $ \entry -> do+        let child = if null relative then entry else relative </> entry+        isDirectory <- doesDirectoryExist (root </> child)+        if isDirectory then walk root child else pure [child]++readRepoText :: FilePath -> IO Text+readRepoText path = resolveRepoPath path >>= TIO.readFile++resolveRepoPath :: FilePath -> IO FilePath+resolveRepoPath path = do+  override <- lookupEnv "KEIRO_DSL_TEST_ROOT"+  let packageRelative = maybe path id (T.unpack <$> T.stripPrefix "keiro-dsl/" (T.pack path))+      candidates = [path, packageRelative] <> maybe [] (\root -> [root </> path, root </> packageRelative]) override+  existing <- filterM doesFileExist candidates+  case existing of+    candidate : _ -> pure candidate+    [] -> fail ("unable to locate repository file " <> show path <> "; tried " <> show candidates)++resolveRepoDirectory :: FilePath -> IO FilePath+resolveRepoDirectory path = do+  override <- lookupEnv "KEIRO_DSL_TEST_ROOT"+  let packageRelative = maybe path id (T.unpack <$> T.stripPrefix "keiro-dsl/" (T.pack path))+      candidates = [path, packageRelative] <> maybe [] (\root -> [root </> path, root </> packageRelative]) override+  existing <- filterM doesDirectoryExist candidates+  case existing of+    candidate : _ -> pure candidate+    [] -> fail ("unable to locate repository directory " <> show path <> "; tried " <> show candidates)++manifestPath :: FilePath+manifestPath = "keiro-dsl/test/frontend-0.7/manifest.json"++diagnosticRoot :: FilePath+diagnosticRoot = "keiro-dsl/test/frontend-0.7/diagnostics"++releasedFrontendEntryPoints :: [Text]+releasedFrontendEntryPoints =+  [ "library.parseSource",+    "library.parseSpec",+    "library.parseSpecText",+    "workspace.parseWorkspaceManifest",+    "workspace.loadWorkspace.members",+    "cli.parse.single",+    "cli.parse.workspace-manifest",+    "cli.check.single",+    "cli.check.workspace",+    "cli.inspect.single",+    "cli.inspect.workspace",+    "cli.behavior-obligations.single",+    "cli.behavior-obligations.workspace",+    "cli.scaffold.single",+    "cli.scaffold.workspace",+    "cli.diff.single-working-tree-and-git-baseline",+    "cli.diff.workspace-working-tree-and-git-baseline"+  ]++diagnosticGoldens :: [(FilePath, IO Text)]+diagnosticGoldens =+  [ ("invalid-preamble.txt", renderParse "invalid-preamble.keiro" "language keiro-dsl nope\ncontext source-fixture\n"),+    ("misplaced-preamble.txt", renderParse "misplaced-preamble.keiro" "context source-fixture\nlanguage keiro-dsl 1\n"),+    ("duplicate-preamble.txt", renderParse "duplicate-preamble.keiro" "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext source-fixture\n"),+    ("feature-nominal-binding-v1.txt", renderParse "feature-nominal-binding-v1.keiro" "context feature\nid OrderId prefix=ord using {}\n"),+    ("feature-integer-v1.txt", renderParse "feature-integer-v1.keiro" integerFeatureSource),+    ("feature-typed-expression-v1.txt", renderParse "feature-typed-expression-v1.keiro" typedExpressionFeatureSource),+    ("feature-explicit-implementation-v1.txt", renderParse "feature-explicit-implementation-v1.keiro" explicitImplementationFeatureSource),+    ("escaped-string.txt", renderParse "escaped-string.keiro" escapedStringSource),+    ("numeric-overflow.txt", renderParse "numeric-overflow.keiro" numericOverflowSource),+    ("duplicate-clause.txt", renderParse "duplicate-clause.keiro" duplicateClauseSource),+    ("expression-error.txt", renderParse "expression-error.keiro" expressionErrorSource),+    ("semantic-error.txt", renderSemantic "semantic-error.keiro" semanticErrorSource),+    ("workspace-member-parse-failure.txt", renderWorkspaceMemberFailure)+  ]++renderParse :: FilePath -> Text -> IO Text+renderParse path source = pure $ case parseSource path source of+  Left failure -> T.stripEnd (renderParseFailure failure) <> "\n"+  Right _ -> error ("diagnostic source unexpectedly parsed: " <> path)++renderSemantic :: FilePath -> Text -> IO Text+renderSemantic path source = pure $ case parseSource path source of+  Left failure -> error ("semantic diagnostic source failed to parse: " <> show failure)+  Right parsed -> case filter ((== Error) . severity) (validateService (checkedSource parsed)) of+    diagnostic : _ -> renderDiagnostic path diagnostic <> "\n"+    [] -> error ("semantic diagnostic source unexpectedly validated: " <> path)++renderWorkspaceMemberFailure :: IO Text+renderWorkspaceMemberFailure = do+  let path = "keiro-dsl/test/fixtures/workspace-member-parse-failed/service.keiro-workspace"+  resolved <- resolveRepoPath path+  loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) path+  pure $ case loaded of+    Left failure -> T.stripEnd (T.unlines (renderWorkspaceFailure path failure)) <> "\n"+    Right _ -> error "workspace-member-parse-failed unexpectedly composed"++integerFeatureSource :: Text+integerFeatureSource =+  T.unlines+    [ "context feature",+      "aggregate Counter",+      "  regs",+      "    value Integer = 0",+      "  states Open"+    ]++typedExpressionFeatureSource :: Text+typedExpressionFeatureSource =+  T.unlines+    [ "context feature",+      "aggregate Counter",+      "  regs",+      "    value Int = 0",+      "  states Open",+      "  command Tick { amount:Int }",+      "  Open -- Tick -->",+      "    guard reg.value == cmd.amount",+      "    goto Open"+    ]++explicitImplementationFeatureSource :: Text+explicitImplementationFeatureSource =+  T.unlines+    [ "context feature",+      "aggregate Counter",+      "  regs",+      "  states Open",+      "  command Tick { }",+      "  Open -- Tick -->",+      "    implementation hole",+      "    goto Open"+    ]++escapedStringSource :: Text+escapedStringSource =+  "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"bad\\q\"\n}\n"++numericOverflowSource :: Text+numericOverflowSource =+  T.unlines+    [ "context svc",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "  event Changed v18446744073709551617 { }"+    ]++duplicateClauseSource :: Text+duplicateClauseSource =+  T.unlines+    [ "context svc",+      "aggregate Thing",+      "  regs",+      "  states Open Closed",+      "  command Move { }",+      "  Open -- Move -->",+      "    goto Closed",+      "    goto Open"+    ]++expressionErrorSource :: Text+expressionErrorSource =+  T.unlines+    [ "language keiro-dsl 2",+      "context svc",+      "aggregate Thing",+      "  regs",+      "    value Int = 0",+      "  states Open",+      "  command Move { amount:Int }",+      "  Open -- Move -->",+      "    guard cmd.amount +",+      "    goto Open"+    ]++semanticErrorSource :: Text+semanticErrorSource =+  T.unlines+    [ "context svc",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "  Open -- MissingCommand -->",+      "    goto Open"+    ]

@@ -0,0 +1,191 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NoFieldSelectors #-}++module Keiro.Dsl.FrontendProfiles (frontendProfilesSpec) where++import Control.Monad (forM_)+import Data.List.NonEmpty qualified as NE+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Frontend+import Keiro.Dsl.FrontendCompatibility (readRepoText)+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser (parseSource)+import Keiro.Dsl.SemanticContract+import Keiro.Dsl.Source+import Keiro.Dsl.Syntax+import Test.Hspec+import Prelude hiding (span)++frontendProfilesSpec :: SpecWith ()+frontendProfilesSpec = do+  describe "released language profiles" $ do+    it "pins each released syntax profile, predecessor, and runtime contract explicitly" $ do+      map definitionRow (NE.toList languageRegistry)+        `shouldBe` [ (1, Nothing, "keiro-dsl/syntax-profile/1", "keiro-dsl/runtime-semantics/1"),+                     (2, Just 1, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/1"),+                     (3, Just 2, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/2")+                   ]+      forM_ allFeatures $ \feature -> do+        languageFeatureMinimumVersion feature `shouldBe` version 2+        languageSupportsFeature (version 1) feature `shouldBe` False+        languageSupportsFeature (version 2) feature `shouldBe` True+        languageSupportsFeature (version 3) feature `shouldBe` True++    it "does not infer a hypothetical successor profile or runtime contract" $ do+      lookupLanguageDefinition (version 4) `shouldBe` Nothing+      effectiveLanguageContractForVersion (version 4) `shouldBe` Nothing+      forM_ allFeatures $ \feature -> languageSupportsFeature (version 4) feature `shouldBe` False+      languageVersionPolicy <- readRepoText "keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs"+      semanticPolicy <- readRepoText "keiro-dsl/src/Keiro/Dsl/SemanticContract.hs"+      languageVersionPolicy `shouldNotSatisfy` T.isInfixOf "version >="+      semanticPolicy `shouldNotSatisfy` T.isInfixOf "version >="++    it "checks every real feature marker against the exact selected profile" $ do+      forM_ featureCases $ \FeatureCase {feature, marker, body} ->+        forM_ [1, 2, 3] $ \versionNumber -> do+          let sourceName = "profile-" <> show versionNumber <> ".keiro"+              source = preamble versionNumber <> body+          case (versionNumber, parseSurfaceSource sourceName source) of+            (1, Left FrontendFailure {phase, code, span, supportedVersions}) -> do+              phase `shouldBe` BodyParsingPhase+              code `shouldBe` SourceLanguageError LanguageFeatureRequiresVersion+              spanText source span `shouldBe` marker+              supportedVersions `shouldBe` [version 2, version 3]+              languageSupportsFeature (version versionNumber) feature `shouldBe` False+            (1, result) -> expectationFailure ("expected v1 feature refusal, got " <> show result)+            (_, Right _) -> languageSupportsFeature (version versionNumber) feature `shouldBe` True+            (_, Left failure) -> expectationFailure (T.unpack (renderFrontendFailure failure))++    it "keeps feature spellings inert in comments, strings, wire keys, and identifiers" $ do+      inertBody <- readRepoText "keiro-dsl/test/fixtures/language-identifier-v1.keiro"+      forM_ [1, 2, 3] $ \versionNumber ->+        parseSurfaceSource ("inert-" <> show versionNumber <> ".keiro") (preamble versionNumber <> inertBody)+          `shouldSatisfy` isRight++  describe "frontend diagnostics" $ do+    it "classifies malformed and unsupported preambles at source selection with exact spans" $ do+      assertSourceSelection InvalidLanguageVersion "language keiro-dsl nope\ncontext malformed\n" "language keiro-dsl nope"+      assertSourceSelection UnsupportedLanguageVersion "language keiro-dsl 4\ncontext future\n" "language keiro-dsl 4"++    it "reports ordinary body syntax with expected items and a point span" $ do+      let source = "language keiro-dsl 1\ncontext body\nlayout\n"+      case parseSurfaceSource "body.keiro" source of+        Left FrontendFailure {phase, code, span = SourceSpan {start, end}, message, expected} -> do+          phase `shouldBe` BodyParsingPhase+          code `shouldBe` BodySyntaxError+          start `shouldBe` end+          message `shouldSatisfy` T.isInfixOf "unexpected end of input"+          expected `shouldSatisfy` (not . null)+        other -> expectationFailure ("expected structured body failure, got " <> show other)++    it "converts lowering refusals into the common phase/code/span model" $ do+      surface <- parseRight "owned.keiro" "context owned\n"+      let corrupted = case surface of+            SurfaceSource {source, language, preamble = sourcePreamble, spec = Located {span = SourceSpan {start, end}, value}} ->+              SurfaceSource+                { source,+                  language,+                  preamble = sourcePreamble,+                  spec = Located {span = SourceSpan {source = "other.keiro", start, end}, value}+                }+      case lowerSurfaceSource corrupted of+        Left lowering@LoweringFailure {span = loweringSpan} ->+          case frontendFailureFromLowering lowering of+            FrontendFailure {phase, code, span} -> do+              phase `shouldBe` LoweringPhase+              code `shouldBe` LoweringError SourceNameMismatch+              span `shouldBe` loweringSpan+        Right _ -> expectationFailure "expected lowering refusal"++    it "keeps the released compatibility renderer byte-identical" $ do+      forM_+        [ "language keiro-dsl nope\ncontext malformed\n",+          "language keiro-dsl 4\ncontext future\n",+          preamble 1 <> featureBody TypedAggregateExpressionSyntax,+          "language keiro-dsl 1\ncontext\n"+        ]+        $ \source -> case (parseSurfaceSource "compat.keiro" source, parseSource "compat.keiro" source) of+          (Left frontendFailure, Left compatibilityFailure) ->+            renderFrontendFailure frontendFailure `shouldBe` renderParseFailure compatibilityFailure+          other -> expectationFailure ("expected matching failures, got " <> show other)++data FeatureCase = FeatureCase+  { feature :: !LanguageFeature,+    marker :: !Text,+    body :: !Text+  }++featureCases :: [FeatureCase]+featureCases =+  [ FeatureCase NominalBindingSyntax "using" (featureBody NominalBindingSyntax),+    FeatureCase IntegerScalarSyntax "Integer" (featureBody IntegerScalarSyntax),+    FeatureCase TypedAggregateExpressionSyntax "cmd." (featureBody TypedAggregateExpressionSyntax),+    FeatureCase ExplicitTransitionImplementationSyntax "implementation hole" (featureBody ExplicitTransitionImplementationSyntax)+  ]++featureBody :: LanguageFeature -> Text+featureBody = \case+  NominalBindingSyntax -> T.unlines ["context profile", "id ProfileId prefix=profile using {}"]+  IntegerScalarSyntax -> T.unlines ["context profile", "aggregate Counter", "  regs", "    count Integer = 0", "  states Open"]+  TypedAggregateExpressionSyntax ->+    T.unlines+      [ "context profile",+        "aggregate Counter",+        "  regs",+        "    count Int = 0",+        "  states Open",+        "  command Add { amount:Int }",+        "  event Added = fields(Add)",+        "  Open -- Add --> guard cmd.amount == reg.count ; emit Added ; goto Open"+      ]+  ExplicitTransitionImplementationSyntax ->+    T.unlines+      [ "context profile",+        "aggregate Counter",+        "  regs",+        "  states Open",+        "  command Tick {}",+        "  event Ticked = fields(Tick)",+        "  Open -- Tick --> implementation hole ; emit Ticked ; goto Open"+      ]++allFeatures :: [LanguageFeature]+allFeatures = [NominalBindingSyntax, IntegerScalarSyntax, TypedAggregateExpressionSyntax, ExplicitTransitionImplementationSyntax]++preamble :: Int -> Text+preamble versionNumber = "language keiro-dsl " <> T.pack (show versionNumber) <> "\n"++version :: Int -> LanguageVersion+version number = maybe (error "invalid test language version") id (languageVersion (fromIntegral number))++definitionRow :: LanguageDefinition -> (Integer, Maybe Integer, Text, Text)+definitionRow definition =+  ( fromIntegral (languageVersionNumber (definitionVersion definition)),+    fromIntegral . languageVersionNumber <$> definitionPredecessor definition,+    syntaxProfileIdentifier (definitionSyntaxProfile definition),+    definitionRuntimeSemantics definition+  )++assertSourceSelection :: SourceLanguageErrorCode -> Text -> Text -> Expectation+assertSourceSelection expectedCode source expectedSpan =+  case parseSurfaceSource "selection.keiro" source of+    Left FrontendFailure {phase, code, span} -> do+      phase `shouldBe` SourceSelectionPhase+      code `shouldBe` SourceLanguageError expectedCode+      spanText source span `shouldBe` expectedSpan+    other -> expectationFailure ("expected structured source-selection failure, got " <> show other)++parseRight :: FilePath -> Text -> IO SurfaceSource+parseRight sourceName source =+  case parseSurfaceSource sourceName source of+    Left failure -> expectationFailure (T.unpack (renderFrontendFailure failure)) >> fail "unreachable"+    Right value -> pure value++spanText :: Text -> SourceSpan -> Text+spanText source SourceSpan {start = SourcePoint {offset = startOffset}, end = SourcePoint {offset = endOffset}} =+  T.take (endOffset - startOffset) (T.drop startOffset source)++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight (Left _) = False

@@ -0,0 +1,77 @@+-- | Compile-time evidence for the public parser and renderer surface released+-- by keiro-dsl-0.7.0.0. Later frontend refactors may change implementations,+-- but these assignments must keep compiling.+module Keiro.Dsl.FrontendPublicApiProbe+  ( apiProbe,+  )+where++import Data.Text (Text)+import Keiro.Dsl.Frontend (FrontendFailure, LoweringFailure, lowerSurfaceSource, parseSurfaceSource)+import Keiro.Dsl.Grammar (Name, Node, Placement, Spec, specContext, specLayout, specModuleRoot, specNodes)+import Keiro.Dsl.LanguageVersion (ParseFailure, ParsedSource, SourceLanguage, SourceLanguageDiagnostic, SourceLanguageErrorCode, parsedSourceLanguage, parsedSpec, sourceLanguageErrorCode)+import Keiro.Dsl.Parser (ParseError, parseSource, parseSpec, parseSpecText)+import Keiro.Dsl.PrettyPrint (renderSource, renderSpec)+import Keiro.Dsl.Syntax (SurfaceSource)++parseSurfaceSourceProbe :: FilePath -> Text -> Either FrontendFailure SurfaceSource+parseSurfaceSourceProbe = parseSurfaceSource++lowerSurfaceSourceProbe :: SurfaceSource -> Either LoweringFailure ParsedSource+lowerSurfaceSourceProbe = lowerSurfaceSource++parseSourceProbe :: FilePath -> Text -> Either ParseFailure ParsedSource+parseSourceProbe = parseSource++parseSpecProbe :: FilePath -> Text -> Either ParseError Spec+parseSpecProbe = parseSpec++parseSpecTextProbe :: Text -> Either ParseError Spec+parseSpecTextProbe = parseSpecText++renderSourceProbe :: ParsedSource -> Text+renderSourceProbe = renderSource++renderSpecProbe :: Spec -> Text+renderSpecProbe = renderSpec++parsedSourceLanguageProbe :: ParsedSource -> SourceLanguage+parsedSourceLanguageProbe = parsedSourceLanguage++parsedSpecProbe :: ParsedSource -> Spec+parsedSpecProbe = parsedSpec++sourceLanguageErrorCodeProbe :: SourceLanguageDiagnostic -> SourceLanguageErrorCode+sourceLanguageErrorCodeProbe = sourceLanguageErrorCode++specContextProbe :: Spec -> Name+specContextProbe = specContext++specModuleRootProbe :: Spec -> Maybe Text+specModuleRootProbe = specModuleRoot++specLayoutProbe :: Spec -> Maybe Placement+specLayoutProbe = specLayout++specNodesProbe :: Spec -> [Node]+specNodesProbe = specNodes++-- | Referencing every assignment keeps @-Wall@ useful and makes the module a+-- real compile probe instead of passive documentation.+apiProbe :: ()+apiProbe =+  parseSurfaceSourceProbe `seq`+    lowerSurfaceSourceProbe `seq`+      parseSourceProbe `seq`+        parseSpecProbe `seq`+          parseSpecTextProbe `seq`+            renderSourceProbe `seq`+              renderSpecProbe `seq`+                parsedSourceLanguageProbe `seq`+                  parsedSpecProbe `seq`+                    sourceLanguageErrorCodeProbe `seq`+                      specContextProbe `seq`+                        specModuleRootProbe `seq`+                          specLayoutProbe `seq`+                            specNodesProbe `seq`+                              ()

@@ -0,0 +1,264 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NoFieldSelectors #-}++module Keiro.Dsl.FrontendSurface (frontendSurfaceSpec) where++import Control.Monad (forM_)+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Frontend+import Keiro.Dsl.FrontendCompatibility+  ( CompatibilityManifest (..),+    SourceExpectation (..),+    readCompatibilityManifest,+    readRepoText,+  )+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Parser (parseSource)+import Keiro.Dsl.Source+import Keiro.Dsl.Syntax+import Test.Hspec hiding (Spec)+import Prelude hiding (span)++frontendSurfaceSpec :: SpecWith ()+frontendSurfaceSpec = do+  describe "source spans" $ do+    it "rejects invalid points and backwards spans" $ do+      mkSourcePoint (-1) 1 1 `shouldBe` Nothing+      mkSourcePoint 0 0 1 `shouldBe` Nothing+      mkSourcePoint 0 1 0 `shouldBe` Nothing+      let start = SourcePoint {offset = 3, line = 2, column = 2}+          end = SourcePoint {offset = 2, line = 2, column = 1}+      mkSourceSpan "invalid.keiro" start end `shouldBe` Nothing++    it "locates Unicode-prefixed syntax and excludes trailing comments" $ do+      let leading = "# λ🙂\n"+          preambleText = "language keiro-dsl 2"+          contextText = "context spans"+          idText = "id ThingId prefix=thing"+          source = leading <> preambleText <> "\n" <> contextText <> "\n" <> idText <> "   # trailing\n\n"+      parsed <- parseSurfaceRight "unicode.keiro" source+      case parsed of+        SurfaceSource+          { preamble = Just (Located {span = preambleSpan}),+            spec =+              Located+                { span = bodySpan,+                  value =+                    SurfaceSpec+                      { context = Located {span = contextSpan},+                        items = [Located {span = idSpan, value = SurfaceId _}]+                      }+                }+          } -> do+            spanPoints preambleSpan `shouldBe` (pointAfter leading, pointAfter (leading <> preambleText))+            spanPoints contextSpan+              `shouldBe` ( pointAfter (leading <> preambleText <> "\n"),+                           pointAfter (leading <> preambleText <> "\n" <> contextText)+                         )+            spanPoints idSpan+              `shouldBe` ( pointAfter (leading <> preambleText <> "\n" <> contextText <> "\n"),+                           pointAfter (leading <> preambleText <> "\n" <> contextText <> "\n" <> idText)+                         )+            spanPoints bodySpan `shouldBe` (fst (spanPoints contextSpan), snd (spanPoints idSpan))+        other -> expectationFailure ("unexpected surface shape: " <> show other)++    it "covers a complete multi-line aggregate and an empty document body" $ do+      aggregateSource <- readRepoText "keiro-dsl/test/fixtures/aggregate-scalars.keiro"+      aggregateSurface <- parseSurfaceRight "aggregate-scalars.keiro" aggregateSource+      let aggregateStart = T.length (fst (T.breakOn "aggregate ScalarLedger" aggregateSource))+          aggregateEnd = T.length (T.stripEnd aggregateSource)+      case aggregateSurface of+        SurfaceSource+          { spec =+              Located+                { value =+                    SurfaceSpec+                      { items = [Located {span = aggregateSpan, value = SurfaceNode (NAggregate _)}],+                        elements+                      }+                }+          } -> do+            spanOffsets aggregateSpan `shouldBe` (aggregateStart, aggregateEnd)+            let fields = [(name, spanText aggregateSource fieldSpan) | Located {span = fieldSpan, value = SurfaceField name} <- elements]+                expressions = [spanText aggregateSource expressionSpan | Located {span = expressionSpan, value = SurfaceExpression _} <- elements]+            fields `shouldContain` [("observedAt", "observedAt:Time")]+            expressions `shouldContain` ["observedAt >= observedAt && revision >= revision"]+        other -> expectationFailure ("unexpected aggregate surface shape: " <> show other)+      emptySurface <- parseSurfaceRight "empty.keiro" "context empty   # trailing\n"+      case emptySurface of+        SurfaceSource+          { spec =+              Located+                { span = bodySpan,+                  value = SurfaceSpec {context = Located {span = contextSpan}, items = []}+                }+          } -> bodySpan `shouldBe` contextSpan+        other -> expectationFailure ("unexpected empty surface shape: " <> show other)++  describe "surface lowering" $ do+    it "preserves top-level source order before grouping the semantic graph" $ do+      let source = T.unlines ["context ordering", "id FirstId prefix=first", "enum Mode { On=on Off=off }", "id SecondId prefix=second"]+      surface <- parseSurfaceRight "ordering.keiro" source+      case surface of+        SurfaceSource {spec = Located {value = SurfaceSpec {items}}} ->+          map topItemKind items `shouldBe` ["id", "enum", "id"]+      lowered <- lowerRight surface+      map idName (specIds (parsedSpec lowered)) `shouldBe` ["FirstId", "SecondId"]+      map enumName (specEnums (parsedSpec lowered)) `shouldBe` ["Mode"]++    it "refuses surface evidence attributed to another source" $ do+      surface <- parseSurfaceRight "owned.keiro" "context owned\n"+      let corrupted = case surface of+            SurfaceSource {source, language, preamble, spec = Located {span = SourceSpan {start, end}, value}} ->+              SurfaceSource+                { source,+                  language,+                  preamble,+                  spec = Located {span = SourceSpan {source = "other.keiro", start, end}, value}+                }+      case lowerSurfaceSource corrupted of+        Left LoweringFailure {code = SourceNameMismatch} -> pure ()+        other -> expectationFailure ("expected source ownership failure, got " <> show other)++    it "lowers every accepted 0.7 fixture to the compatibility result" $ do+      manifest <- readCompatibilityManifest+      forM_ [row | row <- manifestSources manifest, sourceResult row == "accept"] $ \row -> do+        source <- readRepoText (sourcePath row)+        surface <- parseSurfaceRight (sourcePath row) source+        lowered <- lowerRight surface+        parseSource (sourcePath row) source `shouldBe` Right lowered++  describe "parser module boundaries" $ do+    it "keeps the public parser facade free of Megaparsec and grammar productions" $ do+      facade <- readRepoText "keiro-dsl/src/Keiro/Dsl/Parser.hs"+      facade `shouldNotSatisfy` T.isInfixOf "Text.Megaparsec"+      facade `shouldNotSatisfy` T.isInfixOf "keyword ::"+      facade `shouldNotSatisfy` T.isInfixOf "pAggregate ::"+      facade `shouldNotSatisfy` T.isInfixOf "    parseSurfaceSource,"++    it "keeps internal grammar modules from importing the public facade" $+      forM_ parserModulePaths $ \path -> do+        source <- readRepoText path+        filter isFacadeImport (T.lines source) `shouldBe` []++    it "keeps source, syntax, and semantic graph modules Megaparsec-free" $+      forM_ semanticModulePaths $ \path -> do+        source <- readRepoText path+        source `shouldNotSatisfy` T.isInfixOf "Text.Megaparsec"++    it "keeps semantic consumers independent of surface syntax and internal parsers" $+      forM_ semanticConsumerPaths $ \path -> do+        source <- readRepoText path+        source `shouldNotSatisfy` T.isInfixOf "import Keiro.Dsl.Syntax"+        source `shouldNotSatisfy` T.isInfixOf "import Keiro.Dsl.Parser."++    it "keeps workspace loading and parser internals on opposite sides of the facade" $ do+      workspace <- readRepoText "keiro-dsl/src/Keiro/Dsl/Workspace.hs"+      workspace `shouldNotSatisfy` T.isInfixOf "import Keiro.Dsl.Parser."+      forM_ parserModulePaths $ \path -> do+        source <- readRepoText path+        forM_ forbiddenParserDependencies $ \dependency ->+          source `shouldNotSatisfy` T.isInfixOf ("import Keiro.Dsl." <> dependency)++parseSurfaceRight :: FilePath -> Text -> IO SurfaceSource+parseSurfaceRight sourceName source =+  case parseSurfaceSource sourceName source of+    Left failure -> expectationFailure (T.unpack (renderFrontendFailure failure)) >> fail "unreachable"+    Right value -> pure value++lowerRight :: SurfaceSource -> IO ParsedSource+lowerRight source =+  case lowerSurfaceSource source of+    Left failure -> expectationFailure (T.unpack (renderLoweringFailure failure)) >> fail "unreachable"+    Right value -> pure value++spanOffsets :: SourceSpan -> (Int, Int)+spanOffsets SourceSpan {start = SourcePoint {offset = startOffset}, end = SourcePoint {offset = endOffset}} =+  (startOffset, endOffset)++spanPoints :: SourceSpan -> ((Int, Int, Int), (Int, Int, Int))+spanPoints SourceSpan {start, end} = (pointTuple start, pointTuple end)++pointTuple :: SourcePoint -> (Int, Int, Int)+pointTuple SourcePoint {offset, line, column} = (offset, line, column)++pointAfter :: Text -> (Int, Int, Int)+pointAfter prefix =+  ( T.length prefix,+    length linesFound,+    T.length (last linesFound) + 1+  )+  where+    linesFound = T.splitOn "\n" prefix++topItemKind :: Located SurfaceTopItem -> Text+topItemKind Located {value} = case value of+  SurfaceId _ -> "id"+  SurfaceEnum _ -> "enum"+  SurfaceRule _ -> "rule"+  SurfaceNominalScalar _ -> "nominal"+  SurfaceMapped _ -> "mapped"+  SurfaceNode _ -> "node"++spanText :: Text -> SourceSpan -> Text+spanText source SourceSpan {start = SourcePoint {offset = startOffset}, end = SourcePoint {offset = endOffset}} =+  T.take (endOffset - startOffset) (T.drop startOffset source)++isFacadeImport :: Text -> Bool+isFacadeImport line =+  let stripped = T.strip line+   in stripped == "import Keiro.Dsl.Parser"+        || "import Keiro.Dsl.Parser " `T.isPrefixOf` stripped++parserModulePaths :: [FilePath]+parserModulePaths =+  map+    ("keiro-dsl/src/Keiro/Dsl/Parser/" <>)+    [ "Aggregate.hs",+      "Coordination.hs",+      "Core.hs",+      "Declaration.hs",+      "Document.hs",+      "Expression.hs",+      "Integration.hs",+      "Mapped.hs",+      "Preamble.hs",+      "Queue.hs",+      "ReadModel.hs",+      "Workflow.hs"+    ]++semanticModulePaths :: [FilePath]+semanticModulePaths =+  map+    ("keiro-dsl/src/Keiro/Dsl/" <>)+    [ "Source.hs",+      "Syntax.hs",+      "Grammar.hs",+      "Validate.hs"+    ]++semanticConsumerPaths :: [FilePath]+semanticConsumerPaths =+  map+    ("keiro-dsl/src/Keiro/Dsl/" <>)+    [ "Grammar.hs",+      "Validate.hs",+      "SemanticContract.hs",+      "Scaffold.hs",+      "Diff.hs",+      "FoldFingerprint.hs",+      "ReplayImpact.hs"+    ]++forbiddenParserDependencies :: [Text]+forbiddenParserDependencies =+  [ "Workspace",+    "Validate",+    "Scaffold",+    "Diff",+    "FoldFingerprint",+    "ReplayImpact"+  ]

@@ -32,6 +32,9 @@ import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligation (..), BindingObligationKind (..), bindingHoles, bindingObligations, bindingObligationsForService, renderBindingObligations) import Keiro.Dsl.Expression import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprint, aggregateFoldFingerprintForService, aggregateFoldSurface, aggregateFoldSurfaceForService)+import Keiro.Dsl.FrontendCompatibility (frontendCompatibilitySpec)+import Keiro.Dsl.FrontendProfiles (frontendProfilesSpec)+import Keiro.Dsl.FrontendSurface (frontendSurfaceSpec) import Keiro.Dsl.Goldens (GoldenEvidence (..), GoldenPayload (..), emitGoldenPayloads, goldenRelativePath, goldensForDiff) import Keiro.Dsl.Grammar import Keiro.Dsl.Harness (harnessFor, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow)@@ -68,6 +71,10 @@  main :: IO () main = hspec $ do+  frontendCompatibilitySpec+  frontendSurfaceSpec+  frontendProfilesSpec+   describe "source language version" $ do     let legacy = "context hospital-capacity\n"         declared = "# leading comment\n\nlanguage keiro-dsl 1\ncontext hospital-capacity\n"