diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/keiro-dsl.cabal b/keiro-dsl.cabal --- a/keiro-dsl.cabal +++ b/keiro-dsl.cabal @@ -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 diff --git a/src/Keiro/Dsl/Frontend.hs b/src/Keiro/Dsl/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Frontend.hs @@ -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) diff --git a/src/Keiro/Dsl/Frontend/Internal.hs b/src/Keiro/Dsl/Frontend/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Frontend/Internal.hs @@ -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 diff --git a/src/Keiro/Dsl/LanguageVersion.hs b/src/Keiro/Dsl/LanguageVersion.hs --- a/src/Keiro/Dsl/LanguageVersion.hs +++ b/src/Keiro/Dsl/LanguageVersion.hs @@ -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 "" id (sourceLanguageToken diagnostic) diff --git a/src/Keiro/Dsl/Parser.hs b/src/Keiro/Dsl/Parser.hs --- a/src/Keiro/Dsl/Parser.hs +++ b/src/Keiro/Dsl/Parser.hs @@ -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 "" - --- | 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 "" + +-- | 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) diff --git a/src/Keiro/Dsl/Parser/Aggregate.hs b/src/Keiro/Dsl/Parser/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Aggregate.hs @@ -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) + ] + +-------------------------------------------------------------------------------- diff --git a/src/Keiro/Dsl/Parser/Coordination.hs b/src/Keiro/Dsl/Parser/Coordination.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Coordination.hs @@ -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. diff --git a/src/Keiro/Dsl/Parser/Core.hs b/src/Keiro/Dsl/Parser/Core.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Core.hs @@ -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)) diff --git a/src/Keiro/Dsl/Parser/Declaration.hs b/src/Keiro/Dsl/Parser/Declaration.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Declaration.hs @@ -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) diff --git a/src/Keiro/Dsl/Parser/Document.hs b/src/Keiro/Dsl/Parser/Document.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Document.hs @@ -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 diff --git a/src/Keiro/Dsl/Parser/Expression.hs b/src/Keiro/Dsl/Parser/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Expression.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Keiro/Dsl/Parser/Integration.hs b/src/Keiro/Dsl/Parser/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Integration.hs @@ -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 + } diff --git a/src/Keiro/Dsl/Parser/Mapped.hs b/src/Keiro/Dsl/Parser/Mapped.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Mapped.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Keiro/Dsl/Parser/Preamble.hs b/src/Keiro/Dsl/Parser/Preamble.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Preamble.hs @@ -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} diff --git a/src/Keiro/Dsl/Parser/Queue.hs b/src/Keiro/Dsl/Parser/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Queue.hs @@ -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 + } diff --git a/src/Keiro/Dsl/Parser/ReadModel.hs b/src/Keiro/Dsl/Parser/ReadModel.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/ReadModel.hs @@ -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"] diff --git a/src/Keiro/Dsl/Parser/Workflow.hs b/src/Keiro/Dsl/Parser/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Parser/Workflow.hs @@ -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) + +-------------------------------------------------------------------------------- diff --git a/src/Keiro/Dsl/SemanticContract.hs b/src/Keiro/Dsl/SemanticContract.hs --- a/src/Keiro/Dsl/SemanticContract.hs +++ b/src/Keiro/Dsl/SemanticContract.hs @@ -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 diff --git a/src/Keiro/Dsl/Source.hs b/src/Keiro/Dsl/Source.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Source.hs @@ -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) diff --git a/src/Keiro/Dsl/Syntax.hs b/src/Keiro/Dsl/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Syntax.hs @@ -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) diff --git a/test/Keiro/Dsl/FrontendCompatibility.hs b/test/Keiro/Dsl/FrontendCompatibility.hs new file mode 100644 --- /dev/null +++ b/test/Keiro/Dsl/FrontendCompatibility.hs @@ -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" + ] diff --git a/test/Keiro/Dsl/FrontendProfiles.hs b/test/Keiro/Dsl/FrontendProfiles.hs new file mode 100644 --- /dev/null +++ b/test/Keiro/Dsl/FrontendProfiles.hs @@ -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 diff --git a/test/Keiro/Dsl/FrontendPublicApiProbe.hs b/test/Keiro/Dsl/FrontendPublicApiProbe.hs new file mode 100644 --- /dev/null +++ b/test/Keiro/Dsl/FrontendPublicApiProbe.hs @@ -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` + () diff --git a/test/Keiro/Dsl/FrontendSurface.hs b/test/Keiro/Dsl/FrontendSurface.hs new file mode 100644 --- /dev/null +++ b/test/Keiro/Dsl/FrontendSurface.hs @@ -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" + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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"