tramaj-hs (empty) → 0.3.0.0

raw patch · 16 files changed

+5775/−0 lines, 16 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, directory, filepath, hspec, megaparsec, scientific, text, tramaj-hs, vector

Files

• CHANGELOG.md +100/−0
• LICENSE +21/−0
• src/Tramaj/Analysis.hs +333/−0
• src/Tramaj/Ast.hs +505/−0
• src/Tramaj/Eval.hs +1238/−0
• src/Tramaj/Node.hs +183/−0
• src/Tramaj/Parser.hs +974/−0
• src/Tramaj/Types.hs +521/−0
• test/unit/Main.hs +1/−0
• test/unit/Tramaj/AnalysisSpec.hs +226/−0
• test/unit/Tramaj/CorpusSpec.hs +149/−0
• test/unit/Tramaj/EvalSpec.hs +649/−0
• test/unit/Tramaj/NodeJsonSpec.hs +199/−0
• test/unit/Tramaj/ParserSpec.hs +375/−0
• test/unit/Tramaj/TypesSpec.hs +217/−0
• tramaj-hs.cabal +84/−0

@@ -0,0 +1,100 @@+# Changelog++## 0.3.0.0++Implements v2 of the language. This is a rewrite of the semantic core, not an+extension of it -- every program, every host and every fixture is affected.+`../specs/decisions.md` records the design conflicts this resolved and which+reading of the specs won.++**Documents are expressions.** `Element` and `Fragment` are ordinary `Expr`+constructors, so a document node is a value that can be bound, passed to a+lambda and returned from one -- which is what makes the JSX-children pattern+work. The separate template-phase AST (`TemplateNode`, `TElement`, `TValue`,+`TMap`, `TBranch`) and its duplicated `map`/`branch` forms are gone, and so is+`JsonProgram`: `Program` is now `DocumentProgram`/`ExpressionProgram`, told+apart by the root's own form.++**New `Tramaj.Node`**, the normative interchange format specified in+`../specs/node-json.md` and implemented with both an encoder and a strict+decoder. `Text` carries a `Value` rather than a `String` and `Element` gains a+value slot, so a scalar child stays a scalar instead of being stringified;+attribute values are arbitrary values; an element may carry any number of+actions rather than at most one; fragments are real nodes; and every node+carries an annotations map that transformations preserve.++**New `Tramaj.Analysis`**: `staticImportNames`, `staticActionKeys` and+`contextHoles`, each with a deep variant that follows imports through a+library table and cuts cycles, plus `contextReads` (every path a program+reads from its own context) and `unsuppliedParams` (per import, what its+library reads and the import does not supply). `staticActionKeys` applies+action adaptation rather than ignoring it, so a prefixed subtree's keys are+known without evaluating anything.++**Imports take their parameters three ways.** One+`import(name, {k: expr, k2: ctx(path)})` form; `partial-import` is gone, and+so is v1's `tryPartial` heuristic, which inferred partiality by running a+library and catching a `PathNotFound` that started with `ctx`. A parameter is+supplied by an expression, by `ctx(path)` -- which reads the *importing*+program's own `$ctx.path` where the import is written, and exists as its own+form so `contextHoles` can enumerate the holes statically -- or by being left+out and supplied later, by calling the import with more parameters+(right-biased). An import runs when a field is read off it, `.rendered` or+`.vals`, not where it is written, so one wired-up import can serve a whole+`map`. A parameter nobody supplies is the library's own `PathNotFound`,+wrapped in the new `InLibrary` error naming the library that raised it.+`../specs/decisions.md` #10 has the reasoning.++**Other language changes.** `a <> b` concatenates strings, arrays or objects+(mixed types rejected, objects right-biased). `branch` is uniformly lazy and a+core constructor rather than a builtin, so an unreached arm's errors never+surface. `remap-actions` becomes `adapt-actions(node, prefix("ns:") | identity+[, fn])`, its prefix a static literal, its optional closure limited to the+event type and payload. Fragments are written `.(a, b)`. An action's event+joins its key in being a static literal. String literals gain escape sequences+including `\u{...}`; objects gain shorthand `{foo}` and bare keys. Builtins are+values in the initial environment, so one can be passed by reference; `str` is+new and `branch` is no longer among them.++Two parser bugs found while porting, both of the shape the 2026-08-26 pass+fixed for special forms: a malformed `action(...)`/`value(...)` in an element+argument backtracked into a meaningless `Call` instead of failing, and a+backtick in a static string position was silently taken as a literal rather+than reported as an interpolation that cannot go there.++Not yet ported to the PureScript `tramaj` package, which still implements v1.++## Unreleased++Adds `fold(arr, init, fn)`, a fourth functional array primitive alongside+`map`/`filter`/`scan`: same `(acc, item)` step and `scanl` iteration order as+`scan`, but returns only the final accumulator instead of every intermediate+step. Also adds `concat(a, b, ...)` (variadic array-joining) and+`append(arr, item)` (add a single element at the end) as ordinary builtins.+Purely additive; no existing behavior changed. Ported in lockstep to the+PureScript `tramaj` package.++Adds object destructuring patterns (`../specs/decisions.md` \S17) in `@`+bindings and lambda parameters: `@{title, meta: {owner}} = $ctx.item`,+`({a, b}) => ...`. Purely a parser lowering to plain `Let`/`Lambda`; defaults,+rest, array patterns, empty patterns, duplicate names and annotated patterns+are parse errors. Adds `Tramaj.Ast.isHiddenName`: the hidden names the+lowering invents (`#src`, `#argN`) are never a symbol's `"binding"` and never+appear in a library's `.vals`.++## 0.2.0.0++Adds a JSON-producing mode for hosts that want the data half of the language on+its own: `Tramaj.Ast.JsonProgram`, `Tramaj.Parser.parseJsonProgram` and+`Tramaj.Eval.evalJsonProgram`. Same computation block and same expression+language as `parseProgram`/`evalProgram`, but the root is an expression rather+than an element, so the result is an aeson `Value` instead of a document `Node`+-- nothing is stringified through `jsonToDisplayString`. Purely additive; no+existing behavior changed. Haskell-only, with no counterpart in the PureScript+`tramaj` package.++## 0.1.0.0++Initial release, extracted from the repository it was written in. Ports the+PureScript `tramaj` package's `Tramaj.Ast` / `Tramaj.Parser` /+`Tramaj.Eval` to megaparsec + aeson.

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Lucas DiCioccio++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,333 @@+-- | Static analysis: what a program depends on, what it can emit, and what it+-- still needs -- all answered by walking the AST, without evaluating it,+-- without a context, and without running any host code.+--+-- @../specs/laws.md@ asks for exactly three things under "static analysis":+-- the set and precedence of imports, the set of possible actions, and bubbled+-- up context holes. Each is one function below. They are cheap by+-- construction, because the language puts the identifying half of every such+-- construct in a static position: an import's name, an action's key, an+-- adaptation's prefix and a @ctx(...)@ parameter's path are all 'Text' in the+-- AST, never expressions.+--+-- Each analysis comes in two depths. The shallow one reads a single program.+-- The deep one follows imports through a 'LibraryTable', which is what a host+-- actually wants -- "which actions can this page dispatch?" is a question+-- about a program /and everything it imports/ -- and is cycle-safe, returning+-- what it could reach rather than looping.+module Tramaj.Analysis+  ( staticImportNames+  , transitiveImportNames+  , staticActionKeys+  , deepActionKeys+  , contextHoles+  , deepContextHoles+  , contextReads+  , unsuppliedParams+  , constraintKinds+  , deepConstraintKinds+  , symbolSites+  , symbolDemands+  , deepSymbolDemands+  , typeDeclarations+  , typeParams+  , unsuppliedTypeParams+  , typeParamCollisions+  , typeExprsIn+  , everywhere+  , everywhereIn+  ) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Tramaj.Ast++-- | Collects from an expression and every expression inside it.+everywhere :: (Monoid m) => (Expr -> m) -> Expr -> m+everywhere f e = f e <> foldMap (everywhere f) (subExprs e)++everywhereIn :: (Monoid m) => (Expr -> m) -> Program -> m+everywhereIn f = everywhere f . programRoot++-- Imports ---------------------------------------------------------------------++-- | Every library this program imports directly.+staticImportNames :: Program -> Set Text+staticImportNames = everywhereIn $ \case+  Import name _ -> Set.singleton name+  _ -> Set.empty++-- | Every library reachable from this program, directly or through another+-- import. A name that is imported but missing from the table is still+-- reported -- an unresolvable dependency is exactly what a caller wants to+-- hear about -- and a cycle terminates instead of looping.+transitiveImportNames :: Map Text Program -> Program -> Set Text+transitiveImportNames libs = go Set.empty . staticImportNames+  where+    go seen frontier = case Set.minView (frontier `Set.difference` seen) of+      Nothing -> seen+      Just (name, _) ->+        let seen' = Set.insert name seen+            next = maybe Set.empty staticImportNames (Map.lookup name libs)+         in go seen' (Set.union (frontier `Set.difference` seen') next)++-- Actions -----------------------------------------------------------------------++-- | Every action key this program can emit from its own AST.+--+-- Adaptation is applied rather than ignored: @adapt-actions(x, prefix("user:"))@+-- over a subtree whose keys are @{save, delete}@ contributes+-- @{user:save, user:delete}@, using the very same 'adaptKey' the evaluator+-- will. This is the payoff of restricting adaptation to identity-or-prefix.+--+-- Keys living inside an imported library are /not/ included -- this function+-- sees one program. Use 'deepActionKeys' to follow imports.+staticActionKeys :: Program -> Set Text+staticActionKeys = actionKeysIn . programRoot++actionKeysIn :: Expr -> Set Text+actionKeysIn (AdaptActions target adaptation fn) =+  Set.map (adaptKey adaptation) (actionKeysIn target) <> foldMap actionKeysIn fn+actionKeysIn e = ownKeys e <> foldMap actionKeysIn (subExprs e)+  where+    ownKeys (Element _ attrs _ _) = Set.fromList [k | ActionAttr _ k _ <- attrs]+    ownKeys _ = Set.empty++-- | Every action key this program can emit, following imports.+--+-- An import contributes its library's own keys, adapted by any+-- @adapt-actions@ wrapping it -- so @adapt-actions(import("button", ...),+-- prefix("deployment:"))@ over a library emitting @deploy@ yields+-- @deployment:deploy@ without either program being run.+--+-- This is an over-approximation on purpose: it reports what the program+-- /could/ emit, including keys under a 'Branch' arm that a given context will+-- never select. A missing library contributes nothing, and a cycle is cut.+deepActionKeys :: Map Text Program -> Program -> Set Text+deepActionKeys libs prog = go Set.empty (programRoot prog)+  where+    go seen (AdaptActions target adaptation fn) =+      Set.map (adaptKey adaptation) (go seen target) <> foldMap (go seen) fn+    go seen (Import name params)+      | Set.member name seen = fromParams+      | otherwise = fromParams <> maybe Set.empty (go (Set.insert name seen) . programRoot) (Map.lookup name libs)+      where+        fromParams = foldMap (go seen) [e | (_, PExpr e) <- params]+    go seen e = ownKeys e <> foldMap (go seen) (subExprs e)+      where+        ownKeys (Element _ attrs _ _) = Set.fromList [k | ActionAttr _ k _ <- attrs]+        ownKeys _ = Set.empty++-- Context holes ---------------------------------------------------------------------++-- | Every path this program declares as a hole with @ctx(path)@ -- the values+-- its own context must carry for its imports to be wired up.+--+-- These are reads from /this/ program's @$ctx@, performed where each import is+-- written. What makes them worth a function of their own is that the author+-- marked them: 'contextReads' finds every context read, 'contextHoles' finds+-- the ones written as holes, and only the second is a promise about what feeds+-- an import.+contextHoles :: Program -> Set [Text]+contextHoles = everywhereIn $ \case+  Import _ params -> Set.fromList [path | (_, PFromContext path) <- params]+  _ -> Set.empty++-- | Context holes of this program and of every library it imports -- the+-- "bubbled up" view: what the whole dependency tree declares as holes.+--+-- Note that a hole in an imported library is a hole in /that library's/+-- context, which is the parameter object its importer hands it -- not a path+-- in this program's context. The paths are reported as written, and it is the+-- import that wires the library up which decides where each is filled from.+deepContextHoles :: Map Text Program -> Program -> Set [Text]+deepContextHoles libs prog =+  contextHoles prog+    <> foldMap (maybe Set.empty contextHoles . flip Map.lookup libs) (transitiveImportNames libs prog)++-- | Every path this program reads out of its own context, however it is+-- written: @$ctx.a.b@ and a @ctx(a.b)@ import parameter both count.+--+-- For a library, this is the shape of the parameter object it expects, since a+-- library's @$ctx@ /is/ its parameters -- which is what makes+-- 'unsuppliedParams' possible.+--+-- A bare @$ctx@, with no path, reads the whole context and contributes the+-- empty path.+contextReads :: Program -> Set [Text]+contextReads = everywhereIn $ \case+  Path "ctx" fields -> Set.singleton fields+  Import _ params -> Set.fromList [path | (_, PFromContext path) <- params]+  _ -> Set.empty++-- | For each import in this program, the paths its library reads from its+-- context that the import does not supply -- the parameters that still have to+-- be saturated by calling the import value before a field is read off it.+--+-- One entry per import site, in traversal order, so two imports of the same+-- library with different parameters are reported separately. An import whose+-- library is missing from the table contributes an empty set: what it needs is+-- unknowable, not nothing, and 'staticImportNames' is where an unresolvable+-- dependency is reported.+--+-- Two deliberate imprecisions, both in the safe direction for a caller asking+-- "what have I forgotten?":+--+-- * It over-reports, like 'deepActionKeys': a path a library reads only in a+--   @branch@ arm that never fires still counts as needed.+-- * It stops at the library's own reads and does not follow that library's+--   imports, whose parameters that library supplies itself.+--+-- A read is attributed to a parameter by its first segment, so a library+-- reading @$ctx.spec.replicas@ needs the parameter @spec@; the whole path is+-- reported, because the shape wanted is more useful than the name alone. A+-- bare @$ctx@ read names no parameter and is skipped.+unsuppliedParams :: Map Text Program -> Program -> [(Text, Set [Text])]+unsuppliedParams libs = everywhereIn $ \case+  Import name params -> [(name, missingFor name params)]+  _ -> []+  where+    missingFor name params =+      Set.filter (unsupplied (Set.fromList (map fst params))) $+        maybe Set.empty contextReads (Map.lookup name libs)+    unsupplied _ [] = False+    unsupplied supplied (root : _) = not (Set.member root supplied)++-- Constraints -------------------------------------------------------------------++-- | Every constraint name this program can emit from its own AST+-- (v3-symbols \S7). Answerable statically because a @constraint(...)@'s name+-- is a static string, like an action's event and key.+constraintKinds :: Program -> Set Text+constraintKinds = everywhereIn $ \case+  Constrain name _ -> Set.singleton name+  _ -> Set.empty++-- | Every constraint name this program can emit, following imports -- the+-- question a host actually wants answered before it decides whether it+-- supports a template (v3-symbols \S7: "lets a host decide ... before+-- running it"). Over-approximates like 'deepActionKeys': a kind emitted only+-- under a 'Branch' arm no context will select is still reported, and a+-- missing library contributes nothing rather than failing.+deepConstraintKinds :: Map Text Program -> Program -> Set Text+deepConstraintKinds libs prog = go Set.empty (programRoot prog)+  where+    go seen (Import name params)+      | Set.member name seen = fromParams+      | otherwise = fromParams <> maybe Set.empty (go (Set.insert name seen) . programRoot) (Map.lookup name libs)+      where+        fromParams = foldMap (go seen) [e | (_, PExpr e) <- params]+    go seen e = ownKind e <> foldMap (go seen) (subExprs e)+      where+        ownKind (Constrain name _) = Set.singleton name+        ownKind _ = Set.empty++-- Symbols -------------------------------------------------------------------++-- | The @?(k)@ allocation sites this program contains (v3-symbols \S7) --+-- sites, not keys, since the number of symbols a site produces is a runtime+-- fact (one per @map@ iteration, say) but the number of sites is not.+--+-- This is also the static counterpart of 'AllocationInLibrary' (\S6): a+-- program with a non-empty 'symbolSites' cannot serve as a library, which is+-- exactly the check 'Tramaj.Eval.runLibrary' makes before evaluating one.+symbolSites :: Program -> Set Int+symbolSites = everywhereIn $ \case+  Alloc site _ -> Set.singleton site+  _ -> Set.empty++-- | Every context path this program declares symbolic with @?ctx.…@ (\S7),+-- directly -- the demand form's counterpart of 'contextHoles'.+symbolDemands :: Program -> Set [Text]+symbolDemands = everywhereIn $ \case+  Demand path -> Set.singleton path+  _ -> Set.empty++-- | Demands bubbled up through every library this program imports, the way+-- 'deepContextHoles' bubbles up @ctx(...)@ holes -- the counterpart of+-- ref \S9's @unsuppliedParams@ for this feature (\S7): since only the root+-- may allocate, knowing which paths the libraries beneath will discuss+-- symbolically /is/ the whole planning problem, answered without running+-- anything.+deepSymbolDemands :: Map Text Program -> Program -> Set [Text]+deepSymbolDemands libs prog =+  symbolDemands prog+    <> foldMap (maybe Set.empty symbolDemands . flip Map.lookup libs) (transitiveImportNames libs prog)++-- Types -----------------------------------------------------------------------++-- | Every name this program declares with @type ... = ...@ (v4-types \S9) --+-- the type-realm counterpart of a program's own let-bound names, and the+-- source 'Tramaj.Types.resolveTypeExpr' consults for a bare 'TName'.+typeDeclarations :: Program -> Set Text+typeDeclarations prog = Set.fromList (map fst (typeDecls (fst (unlets (programRoot prog)))))++-- | The @%ctx.*@ paths one 'TypeExpr' mentions directly -- 'TVar' is a leaf,+-- so this is a plain fold, with no need to stop at a 'TName'\/'TLibRef' the+-- way 'Tramaj.Types.resolveTypeExpr' must: a reference's own parameters are+-- not this program's variables, so there is nothing to recurse into there,+-- and nothing here evaluates or resolves anything.+typeParamsIn :: TypeExpr -> Set [Text]+typeParamsIn (TPrim _) = Set.empty+typeParamsIn (TArray t) = typeParamsIn t+typeParamsIn (TRecord fields) = foldMap (typeParamsIn . snd) fields+typeParamsIn (TUnion arms) = foldMap (maybe Set.empty typeParamsIn . snd) arms+typeParamsIn (TName _) = Set.empty+typeParamsIn (TLibRef _ _) = Set.empty+typeParamsIn (TVar path) = Set.singleton path++-- | Every 'TypeExpr' sitting in one expression's own syntax, not recursing+-- into subexpressions -- 'everywhere' does that part. A declaration's body,+-- an annotation's type, a type constraint's type-marked arguments, and an+-- import parameter's @%@-marked value (v4-types \S2, roadmap Phase 10) are+-- the four positions a 'TypeExpr' can occur in at all.+typeExprsIn :: Expr -> [TypeExpr]+typeExprsIn (TypeDecl _ t _) = [t]+typeExprsIn (TypeAnnotate _ t _ _) = [t]+typeExprsIn (TypeEmit _ args _) = [t | TCType t <- args]+typeExprsIn (Import _ params) = [t | (_, PType t) <- params]+typeExprsIn _ = []++-- | Every @%ctx.*@ path this program mentions in a type-bearing position+-- (v4-types \S9, roadmap Phase 10) -- its type-level parameter list, the way+-- 'contextReads' is a program's value-level one. This is what a library+-- exposes for its importer to supply via a @%@-marked param (\S2), and it+-- must include a forwarding import's own @%ctx.*@ params, not only what a+-- @type ... = ...@ declaration mentions directly: forwarding+-- (@import(\"inner\", {payload: %ctx.payload})@, \S2) is exactly how a+-- library that itself has no annotated declaration still has an+-- unsaturated parameter its own importer must close.+typeParams :: Program -> Set [Text]+typeParams = everywhereIn (foldMap typeParamsIn . typeExprsIn)++-- | For each import in this program, the type params ('typeParams') its+-- library needs that the import's @%@-marked entries do not supply --+-- 'unsuppliedParams'\' type-side twin (roadmap Phase 10), sharing the same+-- first-segment attribution rule and the same stopping condition: a read is+-- attributed to the parameter its path begins with, and a missing library+-- contributes nothing rather than failing.+unsuppliedTypeParams :: Map Text Program -> Program -> [(Text, Set [Text])]+unsuppliedTypeParams libs = everywhereIn $ \case+  Import name params -> [(name, missingFor name params)]+  _ -> []+  where+    missingFor name params =+      Set.filter (unsupplied (Set.fromList [k | (k, PType _) <- params])) $+        maybe Set.empty typeParams (Map.lookup name libs)+    unsupplied _ [] = False+    unsupplied supplied (root : _) = not (Set.member root supplied)++-- | Param keys this program reads both as an ordinary value hole+-- (@$ctx.k@\/@ctx(k)@) and as a type hole (@%ctx.k@) -- v4-types \S10's+-- @TypeParamCollision@, keyed by first segment exactly as 'unsuppliedParams'+-- and 'unsuppliedTypeParams' both are, since that segment is the parameter+-- name the two channels of \S2.1's one params record would otherwise share.+typeParamCollisions :: Program -> Set Text+typeParamCollisions prog =+  Set.intersection (Set.map firstSegment (contextReads prog)) (Set.map firstSegment (typeParams prog))+  where+    firstSegment [] = ""+    firstSegment (x : _) = x

@@ -0,0 +1,505 @@+-- | The core semantic AST: what a Tramaj program means, after the parser has+-- desugared everything the surface syntax offers on top of it.+--+-- This is a /semantic/ representation, not a parser representation: no source+-- locations, no comments, no formatting, no recovery nodes. Surface+-- conveniences -- string interpolation, object shorthand, @\@name=expr@+-- binding lines, the multi-armed @branch(...)@ form -- have no constructors+-- here; "Tramaj.Parser" lowers them into the constructors below.+--+-- The defining change from v1: **documents are expressions**. 'Element' and+-- 'Fragment' are ordinary 'Expr' constructors, so a document node is a value+-- that can be bound, passed to a lambda, returned from one, or stored in an+-- array like any other. v1's separate template-phase AST -- and with it the+-- duplicated template-phase @map@\/@branch@\/value forms -- is gone.+--+-- Where an invalid program can be made unrepresentable, it is: an import+-- name, an action's event and key, and an action adaptation's prefix are all+-- 'Text' rather than 'Expr', because the language's static-analysis+-- guarantees (see "Tramaj.Analysis") depend on them being knowable without+-- evaluating anything.+--+-- See @../specs/reference.md@ for the language, and @../specs/decisions.md@+-- for which reading of the (now archived) design drafts won where they+-- disagreed.+module Tramaj.Ast+  ( Program (..)+  , Expr (..)+  , Attribute (..)+  , ParamValue (..)+  , ActionAdaptation (..)+  , Stmt (..)+  , TypeExpr (..)+  , TypeConstraintArg (..)+  , programRoot+  , stmts+  , unlets+  , letBindings+  , isHiddenName+  , typeDecls+  , adaptKey+  , subExprs+  , attributeExprs+  , numberAllocs+  ) where++import Data.Text (Text)+import qualified Data.Text as T++-- | A whole program, distinguished by what its root produces rather than by+-- what it may contain -- both halves share one expression language.+--+-- A 'DocumentProgram' evaluates to a "Tramaj.Node" document; an+-- 'ExpressionProgram' evaluates to an ordinary JSON value, for hosts that+-- want the data half of the language on its own. The parser tells them apart+-- syntactically: a root beginning with @.@ is a document.+data Program+  = DocumentProgram Expr+  | ExpressionProgram Expr+  deriving stock (Eq, Show)++programRoot :: Program -> Expr+programRoot (DocumentProgram e) = e+programRoot (ExpressionProgram e) = e++data Expr+  = -- | A name in the environment plus static field segments: @$ctx.user.name@+    -- is @Path "ctx" ["user", "name"]@. Dynamic access goes through the+    -- @lookup@ builtin instead.+    Path Text [Text]+  | -- | Field access on an arbitrary expression, which a 'Path' cannot+    -- express because its root must be a name: @import("x", {}).vals.button@.+    FieldAccess Expr [Text]+  | -- | Application. The function is an 'Expr', not a name, because builtins+    -- are ordinary values in the initial environment -- so @cardinality($xs)@,+    -- @$f($x)@ and @map($xs, $not)@ all travel the same path.+    Call Expr [Expr]+  | -- | A closure over the environment where it is evaluated. Multiple+    -- parameters, since @fold@\/@scan@ need @(acc, item)@ and the language+    -- has no currying. There is no recursion: a binding's value is not in+    -- scope while that value is being evaluated.+    Lambda [Text] Expr+  | -- | One lexical binding. The surface @\@name=expr@ block lowers to nested+    -- 'Let's, which is why a binding may reference earlier ones but not later+    -- ones.+    Let Text Expr Expr+  | StringLit Text+  | NumberLit Double+  | BoolLit Bool+  | NullLit+  | ArrayLit [Expr]+  | ObjectLit [(Text, Expr)]+  | -- | A document element: tag, attributes (ordinary and action, in source+    -- order), a value slot, and children. The value slot is 'NullLit' unless+    -- the template sets one -- see "Tramaj.Node" for what it is for.+    Element Text [Attribute] Expr [Expr]+  | -- | Sibling nodes with no wrapper element -- the JSX-children case,+    -- expressible as an ordinary value because documents are expressions.+    Fragment [Expr]+  | -- | Evaluates its condition, then /only/ the arm it selects. This is the+    -- one place the language departs from evaluating arguments eagerly, and+    -- it is why 'Branch' is a constructor rather than a builtin: errors in an+    -- unreached arm must not surface. The surface's multi-armed+    -- @branch(fallback, p1, v1, ...)@ lowers to nested 'Branch'.+    Branch Expr Expr Expr+  | Map Expr Expr+  | Filter Expr Expr+  | Scan Expr Expr Expr+  | Fold Expr Expr Expr+  | -- | The monoid operation @a \<\> b@, over @String@, @Array@ or @Object@ --+    -- same type on both sides, right-biased on object key collisions.+    Concat Expr Expr+  | -- | A statically named dependency and the parameters supplied to it+    -- /here/ -- not necessarily all of them. An import that omits a parameter+    -- its library reads is saturated later, by calling the import value with+    -- more parameters; there is deliberately no partial-import constructor,+    -- because partiality is not a property of the syntax at all, only of+    -- which names have arrived by the time the library runs.+    Import Text [(Text, ParamValue)]+  | -- | Prefixes every action key in a document subtree, with an optional+    -- closure for the event type and payload. The prefix is static so the+    -- action vocabulary stays enumerable without evaluation.+    AdaptActions Expr ActionAdaptation (Maybe Expr)+  | -- | @constraint(name, arg1, arg2, ...)@ (v3-symbols \S2.1): a static string+    -- name, like an action's event and key, plus any number of ordinary+    -- expressions. Unbounded arity is the point -- a global constraint over a+    -- whole collection is exactly as expressible as a binary comparison.+    Constrain Text [Expr]+  | -- | @!expr@ (v3-symbols \S2.2, \S3): a statement, not a value-producing+    -- form. Nests into the same chain 'Let' does, which is what lets+    -- "earlier bindings only" fall out of ordinary lexical scoping rather+    -- than needing separate statement machinery. Evaluating it collects from+    -- the constraint expression's value by the same coercion table 'Element'+    -- children already use, then continues into the body.+    Emit Expr Expr+  | -- | @?(key)@ (v3-symbols \S1.2): allocates a symbol. @key@ is an ordinary+    -- expression, evaluated where it is written. The 'Int' is the site: the+    -- n-th @?(...)@ in the program's source, in source order -- part of the+    -- symbol's identity (\S1.4), so it belongs to the core AST rather than+    -- being derived some other way. Assigned by 'numberAllocs' after+    -- parsing, not by the parser itself, so that agreement between+    -- implementations rests on one small pure function over the AST rather+    -- than on two parsers' internal traversal order.+    Alloc Int Expr+  | -- | @?ctx.a.b@ (\S1.3): declares a context read symbolic. The path MUST+    -- be rooted at @ctx@, which is why it is not just a 'Path' -- unlike an+    -- ordinary read, an unsupplied demand at the root allocates instead of+    -- failing.+    Demand [Text]+  | -- | @type Name = TypeExpr@ (v4-types \S1.1): a nominal type declaration.+    -- Nests into the same 'Let'\/'Emit' chain as an ordinary binding -- see+    -- roadmap-to-v4 Phase 8 -- which is what keeps 'Program' untouched. The+    -- 'TypeExpr' carries no 'Expr': resolution (v4-types \S9) is a separate+    -- static pass over the chain, not something this constructor threads+    -- through evaluation, so the evaluator never needs to know it exists.+    TypeDecl Text TypeExpr Expr+  | -- | @\@x : T = e@ (v4-types \S7): an annotated binding. Distinct from+    -- 'Let' rather than folding the type into it, because a plain 'Let' must+    -- stay meaningful with no type pass ever having run -- v3 is complete+    -- without this constructor existing at all. An erasure pass (v4-types+    -- \S7, roadmap Phase 11), run before evaluation, rewrites every+    -- 'TypeAnnotate' into the 'Let' plus 'Emit' of a @has-type@ constraint+    -- that \S7 specifies; the evaluator itself never matches this+    -- constructor.+    TypeAnnotate Text TypeExpr Expr Expr+  | -- | @!type-constraint(name, args...)@ (v4-types \S5, roadmap Phase 12): a+    -- sibling of 'Emit' in the type realm. Resolved by the analyser, never+    -- evaluated -- \S5.1 is explicit that the evaluator's statement fold+    -- skips this the way it skips 'TypeDecl'.+    TypeEmit Text [TypeConstraintArg] Expr+  deriving stock (Eq, Show)++-- | One argument to @!type-constraint@ (v4-types \S5): a \"%\"-marked type+-- expression, or a literal scalar. A bare 'Expr' would overreach -- \S5 fixes+-- the argument grammar to exactly these two shapes, computed nowhere, which+-- is what keeps a type constraint statically collectible the way an ordinary+-- @constraint@'s /name/ is (v3-symbols \S2.1) but its arguments are not.+data TypeConstraintArg+  = TCType TypeExpr+  | TCScalarStr Text+  | TCScalarNum Double+  | TCScalarBool Bool+  | TCScalarNull+  deriving stock (Eq, Show)++-- | The type algebra (v4-types \S1), before resolution. Six shapes there+-- become six here, but 'Ref' is split into two pre-resolution forms: 'TName'+-- for a bare local name (@Point@) and 'TLibRef' for a name reached through an+-- import (@$msg.types.Envelope@). Resolution (v4-types \S9, not yet+-- implemented) is what turns either into a genuine @(library, name)@+-- reference or reports 'UnresolvedType' -- parsing alone cannot tell a+-- declaration name from a typo.+--+-- 'TPrim' is recognized here, at parse time, rather than left for resolution+-- to classify: the five primitive names are a closed, reserved lexical set+-- (v4-types \S1), not ordinary identifiers that happen to resolve to a+-- primitive.+data TypeExpr+  = TPrim Text+  | TArray TypeExpr+  | TRecord [(Text, TypeExpr)]+  | TUnion [(Text, Maybe TypeExpr)]+  | TName Text+  | TLibRef Text Text+  | -- | @%ctx.a.b@ (v4-types \S1): a type hole. Unlike 'Demand', this never+    -- allocates anything -- v4-types \S4 requires every 'TVar' to be resolved+    -- away before a program may run at all.+    TVar [Text]+  deriving stock (Eq, Show)++-- | How one import parameter gets its value. There are three ways to supply+-- one and only two of them are here -- the third is leaving it out (see+-- 'Import').+--+-- 'PExpr' is any expression, evaluated where the import is written.+--+-- @PFromContext path@ is @ctx(spec.replicas)@: the value comes from the+-- /importing/ program's own context, read where the import is written. It+-- means what @$ctx.spec.replicas@ means and evaluates identically -- the point+-- of the separate node is entirely static. A path sitting in the AST is a hole+-- "Tramaj.Analysis" can enumerate directly, whereas the same read spelled+-- @$ctx.spec.replicas@ is an ordinary 'Path' buried in an arbitrary+-- expression, indistinguishable from every other read. Writing @ctx(...)@ is+-- how an author says "this is a hole, count it".+-- | @%T@ or @%ctx.path@ in a params record (v4-types \S2): a type argument,+-- told apart from 'PExpr'\/'PFromContext' purely by the leading @%@ the+-- parser already saw -- the params record stays one syntactic form even+-- though it carries two semantic channels (\S2.1). 'PType' carries a full+-- 'TypeExpr' rather than just a name, since @%[T]@, @%{a:T}@ and forwarding+-- @%ctx.path@ are all legal here, not only a bare reference.+data ParamValue+  = PExpr Expr+  | PFromContext [Text]+  | PType TypeExpr+  deriving stock (Eq, Show)++-- | Both attribute-position constructs. An action's event and key are 'Text',+-- not 'Expr': the payload stays fully dynamic, but the identifying half is+-- static, which is what makes the set of actions a program can emit+-- computable ahead of time.+data Attribute+  = Attr Text Expr+  | ActionAttr Text Text Expr+  deriving stock (Eq, Show)++-- | Restricted on purpose to two forms rather than an arbitrary key-rewriting+-- function. Adaptations compose the obvious way: prefixing @a:@ and then+-- @b:@ gives @b:a:key@, needing no "already adapted" state.+data ActionAdaptation+  = Identity+  | Prefix Text+  deriving stock (Eq, Show)++-- | Nests a sequence of statements around a body, innermost last -- the+-- lowering the surface @statement* expr@ program grammar uses (v3-symbols+-- \S2.2): a binding becomes a 'Let', an emission an 'Emit', each wrapping+-- everything that follows it.+stmts :: [Stmt] -> Expr -> Expr+stmts statements body = foldr wrap body statements+  where+    wrap (SLet name value) acc = Let name value acc+    wrap (SEmit constraint) acc = Emit constraint acc+    wrap (STypeDecl name t) acc = TypeDecl name t acc+    wrap (SAnnotate name t value) acc = TypeAnnotate name t value acc+    wrap (STypeEmit name args) acc = TypeEmit name args acc++-- | How an adaptation rewrites one action key. Shared by evaluation and by+-- static analysis, which is the point of restricting adaptation to these two+-- forms: the analysis can apply the very same function the evaluator will,+-- without evaluating anything.+adaptKey :: ActionAdaptation -> Text -> Text+adaptKey Identity key = key+adaptKey (Prefix p) key = p <> key++-- | The immediately-contained expressions of an expression, in source order.+--+-- Written once here so that the analyses in "Tramaj.Analysis" are a few lines+-- each rather than a 20-case fold apiece -- and, more importantly, so that+-- adding a constructor to 'Expr' has exactly one place to be taught about+-- instead of one per traversal.+subExprs :: Expr -> [Expr]+subExprs (Path _ _) = []+subExprs (FieldAccess target _) = [target]+subExprs (Call fn args) = fn : args+subExprs (Lambda _ body) = [body]+subExprs (Let _ value body) = [value, body]+subExprs (StringLit _) = []+subExprs (NumberLit _) = []+subExprs (BoolLit _) = []+subExprs NullLit = []+subExprs (ArrayLit elems) = elems+subExprs (ObjectLit entries) = map snd entries+subExprs (Element _ attrs val children) = attributeExprs attrs <> (val : children)+subExprs (Fragment children) = children+subExprs (Branch c t e) = [c, t, e]+subExprs (Map coll fn) = [coll, fn]+subExprs (Filter coll fn) = [coll, fn]+subExprs (Scan coll initial fn) = [coll, initial, fn]+subExprs (Fold coll initial fn) = [coll, initial, fn]+subExprs (Concat l r) = [l, r]+subExprs (Import _ params) = [e | (_, PExpr e) <- params]+subExprs (AdaptActions target _ fn) = target : maybe [] pure fn+subExprs (Constrain _ args) = args+subExprs (Emit constraint body) = [constraint, body]+subExprs (Alloc _ key) = [key]+subExprs (Demand _) = []+subExprs (TypeDecl _ _ body) = [body]+subExprs (TypeAnnotate _ _ value body) = [value, body]+subExprs (TypeEmit _ _ body) = [body]++-- | The computed expressions in a list of attributes -- an ordinary+-- attribute's value or an action's payload. An action's event and key are+-- static text, so they are not expressions to walk into.+attributeExprs :: [Attribute] -> [Expr]+attributeExprs attrs = [e | attr <- attrs, e <- case attr of Attr _ e -> [e]; ActionAttr _ _ e -> [e]]++-- | One statement of the surface program grammar (v3-symbols \S2.2), after+-- lowering: a binding or an emission. Both nest into the same 'Let'\/'Emit'+-- chain; this is only 'unlets'\' view of it.+data Stmt+  = SLet Text Expr+  | SEmit Expr+  | STypeDecl Text TypeExpr+  | SAnnotate Text TypeExpr Expr+  | STypeEmit Text [TypeConstraintArg]+  deriving stock (Eq, Show)++-- | Peels the outermost 'Let'\/'Emit' chain back off, inverting 'lets'.+--+-- Nothing but a program's surface statement block can put a 'Let' or 'Emit'+-- outermost, so this recovers exactly that block, in order. Keeping+-- statements as ordinary nested constructors in the AST, and recovering the+-- block when it is needed, avoids a second binding construct whose scoping+-- would have to be specified separately.+--+-- Stopping at the first 'Let' alone -- as this once did, before 'Emit'+-- existed -- silently truncates a binding block that has a @!@ statement+-- threaded through it: @\@a=1; !c; \@b=2; root@ would report only @a@.+-- 'runLibrary' is the caller this matters to, since it is what exposes+-- @.vals@ and is also the one place a library's own emissions must be+-- evaluated.+unlets :: Expr -> ([Stmt], Expr)+unlets (Let name value body) = let (stmts, root) = unlets body in (SLet name value : stmts, root)+unlets (Emit constraint body) = let (stmts, root) = unlets body in (SEmit constraint : stmts, root)+unlets (TypeDecl name t body) = let (stmts, root) = unlets body in (STypeDecl name t : stmts, root)+unlets (TypeAnnotate name t value body) = let (stmts, root) = unlets body in (SAnnotate name t value : stmts, root)+unlets (TypeEmit name args body) = let (stmts, root) = unlets body in (STypeEmit name args : stmts, root)+unlets e = ([], e)++-- | Just the named bindings of a statement block, in order -- what an+-- import exposes as @.vals@. An annotated binding (@\@x : T = e@) still+-- binds @x@, so it counts here exactly as a plain 'SLet' does; only+-- emissions and type declarations are discarded positionally. A caller that+-- must also evaluate every statement (running a library) should fold over+-- 'unlets'\' full result instead.+letBindings :: [Stmt] -> [(Text, Expr)]+letBindings stmts = [(n, e) | stmt <- stmts, Just (n, e) <- [asBinding stmt]]+  where+    asBinding (SLet n e) = Just (n, e)+    asBinding (SAnnotate n _ e) = Just (n, e)+    asBinding _ = Nothing++-- | A name the parser invents when lowering a binding pattern (decisions+-- \S17): it starts with @#@, which no surface name can. Such a binding is a+-- lowering detail, so it is never reported as a symbol's @"binding"@ and never+-- exposed through a library's @.vals@.+isHiddenName :: Text -> Bool+isHiddenName = T.isPrefixOf "#"++-- | Just the type declarations of a statement block, in order -- the+-- analogue of 'letBindings' for the type realm (v4-types \S1.1). This is+-- what a later resolution pass (v4-types \S9) collects before resolving any+-- of them, so that a self- or mutually-recursive declaration is visible to+-- the pass before it looks anything up.+typeDecls :: [Stmt] -> [(Text, TypeExpr)]+typeDecls stmts = [(n, t) | STypeDecl n t <- stmts]++-- | Assigns each 'Alloc' in a program the index of its @?(...)@ among all of+-- them, in source order (v3-symbols \S1.4) -- a plain pre-order, left-to-right+-- walk over the freshly parsed tree, numbering as it goes.+--+-- Done as a rewrite after parsing, rather than by a counter threaded through+-- the parser itself, so that two independently written parsers agree on site+-- numbers by construction: both run this same function over what they+-- parsed, rather than having to agree on a parser-internal traversal order.+-- It relies on one property of every constructor below: each rebuilds a node+-- from the *same* immediate subexpressions 'subExprs' would report, in the+-- same order, which is what makes a left-to-right pre-order walk here land+-- on exactly "the n-th @?@ in the source" for every shape the grammar+-- produces -- attributes before value before children in an 'Element',+-- condition before either arm in a 'Branch', and so on.+numberAllocs :: Expr -> Expr+numberAllocs e = snd (go 0 e)+  where+    go :: Int -> Expr -> (Int, Expr)+    go n (Alloc _ key) =+      let (n', key') = go (n + 1) key+       in (n', Alloc n key')+    go n e'@(Path _ _) = (n, e')+    go n (FieldAccess target fields) =+      let (n', target') = go n target in (n', FieldAccess target' fields)+    go n (Call fn args) =+      let (n1, fn') = go n fn+          (n2, args') = goList n1 args+       in (n2, Call fn' args')+    go n (Lambda params body) = let (n', body') = go n body in (n', Lambda params body')+    go n (Let name value body) =+      let (n1, value') = go n value+          (n2, body') = go n1 body+       in (n2, Let name value' body')+    go n e'@(StringLit _) = (n, e')+    go n e'@(NumberLit _) = (n, e')+    go n e'@(BoolLit _) = (n, e')+    go n NullLit = (n, NullLit)+    go n (ArrayLit elems) = let (n', elems') = goList n elems in (n', ArrayLit elems')+    go n (ObjectLit entries) =+      let (n', entries') = goPairs n entries in (n', ObjectLit entries')+    go n (Element tag attrs val children) =+      let (n1, attrs') = goAttrs n attrs+          (n2, val') = go n1 val+          (n3, children') = goList n2 children+       in (n3, Element tag attrs' val' children')+    go n (Fragment children) = let (n', children') = goList n children in (n', Fragment children')+    go n (Branch c t e') =+      let (n1, c') = go n c+          (n2, t') = go n1 t+          (n3, e'') = go n2 e'+       in (n3, Branch c' t' e'')+    go n (Map coll fn) =+      let (n1, coll') = go n coll+          (n2, fn') = go n1 fn+       in (n2, Map coll' fn')+    go n (Filter coll fn) =+      let (n1, coll') = go n coll+          (n2, fn') = go n1 fn+       in (n2, Filter coll' fn')+    go n (Scan coll initial fn) =+      let (n1, coll') = go n coll+          (n2, initial') = go n1 initial+          (n3, fn') = go n2 fn+       in (n3, Scan coll' initial' fn')+    go n (Fold coll initial fn) =+      let (n1, coll') = go n coll+          (n2, initial') = go n1 initial+          (n3, fn') = go n2 fn+       in (n3, Fold coll' initial' fn')+    go n (Concat l r) =+      let (n1, l') = go n l+          (n2, r') = go n1 r+       in (n2, Concat l' r')+    go n (Import name params) =+      let (n', params') = goParams n params in (n', Import name params')+    go n (AdaptActions target adaptation fn) =+      let (n1, target') = go n target+          (n2, fn') = case fn of+            Nothing -> (n1, Nothing)+            Just f -> let (n', f') = go n1 f in (n', Just f')+       in (n2, AdaptActions target' adaptation fn')+    go n (Constrain name args) = let (n', args') = goList n args in (n', Constrain name args')+    go n (Emit constraint body) =+      let (n1, constraint') = go n constraint+          (n2, body') = go n1 body+       in (n2, Emit constraint' body')+    go n e'@(Demand _) = (n, e')+    go n (TypeDecl name t body) = let (n', body') = go n body in (n', TypeDecl name t body')+    go n (TypeAnnotate name t value body) =+      let (n1, value') = go n value+          (n2, body') = go n1 body+       in (n2, TypeAnnotate name t value' body')+    go n (TypeEmit name tcArgs body) = let (n', body') = go n body in (n', TypeEmit name tcArgs body')++    goList :: Int -> [Expr] -> (Int, [Expr])+    goList n [] = (n, [])+    goList n (x : xs) =+      let (n1, x') = go n x+          (n2, xs') = goList n1 xs+       in (n2, x' : xs')++    goPairs :: Int -> [(Text, Expr)] -> (Int, [(Text, Expr)])+    goPairs n [] = (n, [])+    goPairs n ((k, x) : xs) =+      let (n1, x') = go n x+          (n2, xs') = goPairs n1 xs+       in (n2, (k, x') : xs')++    goAttrs :: Int -> [Attribute] -> (Int, [Attribute])+    goAttrs n [] = (n, [])+    goAttrs n (Attr name x : xs) =+      let (n1, x') = go n x+          (n2, xs') = goAttrs n1 xs+       in (n2, Attr name x' : xs')+    goAttrs n (ActionAttr ev key x : xs) =+      let (n1, x') = go n x+          (n2, xs') = goAttrs n1 xs+       in (n2, ActionAttr ev key x' : xs')++    goParams :: Int -> [(Text, ParamValue)] -> (Int, [(Text, ParamValue)])+    goParams n [] = (n, [])+    goParams n ((k, PExpr x) : xs) =+      let (n1, x') = go n x+          (n2, xs') = goParams n1 xs+       in (n2, (k, PExpr x') : xs')+    goParams n ((k, p@(PFromContext _)) : xs) =+      let (n1, xs') = goParams n xs in (n1, (k, p) : xs')+    goParams n ((k, p@(PType _)) : xs) =+      let (n1, xs') = goParams n xs in (n1, (k, p) : xs')

@@ -0,0 +1,1238 @@+{-# LANGUAGE CPP #-}+-- | Evaluates a "Tramaj.Ast" 'Program' against an input context, producing+-- either a "Tramaj.Node" document or an ordinary JSON value.+--+-- There is one evaluator. v1 had two -- an expression evaluator and a+-- template-node evaluator -- because it had two ASTs; now that documents are+-- expressions, 'evalExpr' handles everything, and the only rule the document+-- side adds is how a child value becomes children ('childNodes').+--+-- 'Value'' is the language's full value domain, not JSON with extras bolted+-- on: an array or object may contain document nodes, which is what makes the+-- JSX-children pattern -- passing a fragment to a component as an ordinary+-- parameter -- work without a separate template-value category. JSON is what+-- you get at the boundaries ('toJson'), where a node would be meaningless: an+-- attribute value, an action payload, an element's value slot.+--+-- Evaluation is eager and deterministic everywhere except 'Branch', which+-- evaluates only the arm it selects.+module Tramaj.Eval+  ( EvalError (..)+  , Output (..)+  , Mode (..)+  , LibraryTable+  , evalProgram+  , runProgram+  , evalExprWith+  , builtinNames+  ) where++import Data.Aeson (Value (..), encode)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bifunctor (first)+import Data.Char (intToDigit)+import Data.Foldable (traverse_)+#if __GLASGOW_HASKELL__ >= 910+import Data.List (sortOn)+#else+import Data.List (foldl', sortOn)+#endif+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes)+import Data.Scientific (Scientific, fromFloatDigits, toRealFloat)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import qualified Data.Vector as V+import Numeric (floatToDigits)+import Tramaj.Analysis (symbolSites)+import Tramaj.Ast+import Tramaj.Node+import Tramaj.Types (ResolvedConstraintArg (..), ResolvedType (..), TypeError, canonicalId, deepTypeConstraints, eraseTypes, programTypeRoots, typeClosure)++data EvalError+  = UnboundName Text+  | PathNotFound [Text]+  | TypeMismatch Text+  | UnknownLibrary Text+  | ImportCycle Text+  | -- | @a \<\> b@ where the two sides are not the same concatenable type.+    ConcatMismatch Text Text+  | -- | Whatever went wrong inside an imported library, tagged with which+    -- library it was. Nests, so a failure three imports deep reads as the+    -- chain that reached it. This matters most for the parameter a library+    -- needs and the import never supplied: that surfaces as this library's+    -- own @PathNotFound ["ctx", ...]@, and without the tag there would be+    -- nothing on it to say whose context was short.+    InLibrary Text EvalError+  | -- | A symbol would have to be minted in concrete mode: an allocation+    -- (@?(k)@, v3-symbols \S4) or an unsupplied @?ctx.path@ demand at the root+    -- (\S1.3). Concrete mode has no way to represent either. Symbolic mode+    -- never raises it: that is the one mode where a symbol is representable.+    SymbolsUnavailable+  | -- | A symbolic value where the language requires a concrete one (\S1.5's+    -- table, and a symbol used as an allocation key).+    NotConcrete Text+  | -- | A program containing @?(k)@ is loaded as a library (\S1.4): only the+    -- root may allocate, because the root runs exactly once and a library+    -- does not. Lexical, not data-flow -- raised because the library's own+    -- source contains an allocation site, whether or not evaluation would+    -- ever reach it.+    AllocationInLibrary Text+  | -- | A static v4-types failure (v4-types \S10), surfaced from either the+    -- erasure pass every entry point below runs before evaluating anything+    -- (\S7, roadmap Phase 11) or from building the symbolic envelope's+    -- @\"types\"@\/@\"type-constraints\"@ lists (\S8, Phase 13). Not a new+    -- evaluation failure mode -- nothing here is raised /during/ evaluation+    -- -- but 'Tramaj.Types.TypeError' still needs a home in the one error+    -- type every entry point already returns.+    TypeErr TypeError+  deriving stock (Eq, Show)++-- | What a program produced. Which one it is follows from the value the root+-- actually evaluated to, not from how the root was written: a program whose+-- root is @$header@ yields a document if that binding holds one.+data Output+  = ONode Node+  | OValue Value+  deriving stock (Eq, Show)++-- | A host parameter, not a property of the program (v3-symbols \S5): what an+-- interpreter is willing to read back out, not anything the template itself+-- declares. 'Concrete' is @reference.md@ exactly -- Node JSON or a plain+-- value, byte for byte. 'Symbolic' wraps the same evaluation in the v3+-- envelope (\S5.2); until \S3\/\S4 land, that envelope's @"symbols"@ and+-- @"constraints"@ are always empty, because nothing yet produces either.+data Mode = Concrete | Symbolic+  deriving stock (Eq, Show)++-- | Host-supplied library store. Where a library came from -- a file, an+-- embedded string, a fetch -- is entirely the host's business; the evaluator+-- only ever sees an already-parsed 'Program'.+type LibraryTable = Map Text Program++-- | The language's value domain.+--+-- 'VArray'\/'VObject' hold 'Value'', not JSON, so a document node can travel+-- inside a structure like any other value. 'VEnv' is an import's+-- @{rendered, vals}@ result. 'VImport' is an import that has been wired up but+-- not run -- reading a field off it is what runs it.+--+-- There is no recursion: 'Let' inserts a binding only after evaluating its+-- right-hand side, so a closure cannot see its own name.+data Value'+  = VNull+  | VBool Bool+  | VNumber Scientific+  | VString Text+  | VArray [Value']+  | VObject (Map Text Value')+  | VNode' Node+  | VClosure [Text] Expr Env+  | VBuiltin Text+  | VEnv Env+  | VImport Pending+  | -- | @constraint(name, args...)@ (v3-symbols \S2.1): a value like any+    -- other, so it can be bound, passed around and collected into an array,+    -- right up until it tries to cross a JSON boundary ('toJson' refuses it)+    -- or is left unreached by any @!@.+    VConstraint Text [Value']+  | -- | A symbol (\S1.1): opaque data, identified by 'SymbolId' and a+    -- projection path extended one segment at a time by field access+    -- (\S1.6). An allocation (@?(k)@) starts with an empty path; so does a+    -- demand (@?ctx.path@) once minted -- its own path is baked into the id,+    -- not carried here.+    VSymbol SymbolId [Text]++type Env = Map Text Value'++-- | A symbol's identity (\S1.4): a string, identical in every conforming+-- implementation for the same program and key. Kept distinct from 'Text'+-- only so the two forms ('renderAllocId', 'renderDemandId') stay the only+-- places one is built.+type SymbolId = Text++-- | An entry in the symbol table (\S5.2). Only allocations appear there --+-- which includes an unsupplied demand minted at the root (\S1.3), since+-- that too is the root allocating -- and a symbol the host seeded (\S5.4)+-- is never listed, because the language has nothing to add about one it+-- did not mint.+data SymbolEntry = SymbolEntry+  { seId :: SymbolId+  , seOrigin :: SymbolOrigin+  , seBinding :: Maybe Text+  }+  deriving stock (Eq, Show)++-- | Where a symbol table entry came from: an @?(k)@ at a given site, with+-- the key it was allocated with already reduced to JSON; or an unsupplied+-- @?ctx.path@ demand, minted at the root.+data SymbolOrigin+  = OAlloc Int Value+  | ODemand [Text]+  deriving stock (Eq, Show)++-- | An import that has been named and wired up, and has not run.+--+-- @pParams@ is everything supplied so far, however it arrived: an expression,+-- a @ctx(path)@ read out of the importing program's own context at the wiring+-- site, or a later call adding more. Nothing here records what is still+-- /missing/, because nothing here knows: the library decides that when it runs+-- and reads its @$ctx@. That is the whole point of the design -- an omitted+-- parameter is what defers an import, so partiality needs no declaration and+-- no bookkeeping.+--+-- @pQueued@ holds adaptations applied before the import ran; they run on the+-- result, once there are actions for them to reach.+data Pending = Pending+  { pName :: Text+  , pParams :: Map Text Value'+  , pQueued :: [(ActionAdaptation, Maybe Value')]+  }++-- | Everything evaluation needs to know about that is not the local+-- environment: the library table, the set of libraries already being+-- evaluated on this chain (cycle detection), the mode (v3-symbols \S5), and+-- whether this is the root program or somewhere inside a library (\S1.3,+-- \S1.4) -- bundled so that adding one more such fact, as \S1.4's did,+-- touches this record instead of every function's argument list.+data EvalCtx = EvalCtx+  { ecLibs :: LibraryTable+  , ecInProgress :: Set Text+  , ecMode :: Mode+  , ecIsRoot :: Bool+  }++-- | Enters a library: adds it to the in-progress set (so re-entering it is a+-- cycle, not a loop) and clears 'ecIsRoot' -- a library never allocates or+-- mints (\S1.3, \S1.4), no matter how deep the chain that reached it.+enterLibrary :: Text -> EvalCtx -> EvalCtx+enterLibrary name ctx = ctx {ecInProgress = Set.insert name (ecInProgress ctx), ecIsRoot = False}++-- | What evaluation accumulates alongside its result (v3-symbols \S4):+-- emitted constraints and allocated symbol-table entries, each in+-- evaluation order and each deduplicated only once, globally, at the top+-- (\S4 -- "first position kept") rather than on every append.+data Emissions = Emissions+  { emConstraints :: [Value']+  , emSymbols :: [SymbolEntry]+  }++instance Semigroup Emissions where+  Emissions c1 s1 <> Emissions c2 s2 = Emissions (c1 <> c2) (s1 <> s2)++instance Monoid Emissions where+  mempty = Emissions [] []++-- The evaluation monad -------------------------------------------------------++-- | Evaluation threads two things besides the value it produces: it can fail+-- with an 'EvalError', and it accumulates 'Emissions' monoidally -- appended+-- in evaluation order, never mutated in place, so 'Branch' evaluating only+-- its selected arm gives exactly the right emission set for free, with no+-- separate mechanism.+newtype Eval a = MkEval {runEval :: Either EvalError (a, Emissions)}++instance Functor Eval where+  fmap f (MkEval e) = MkEval (fmap (\(a, w) -> (f a, w)) e)++instance Applicative Eval where+  pure a = MkEval (Right (a, mempty))+  MkEval mf <*> MkEval ma = MkEval $ do+    (f, w1) <- mf+    (a, w2) <- ma+    pure (f a, w1 <> w2)++instance Monad Eval where+  MkEval ma >>= f = MkEval $ do+    (a, w1) <- ma+    (b, w2) <- runEval (f a)+    pure (b, w1 <> w2)++evalError :: EvalError -> Eval a+evalError e = MkEval (Left e)++-- | Brings a pure, non-emitting computation into 'Eval' -- every helper that+-- only inspects already-evaluated 'Value''s (no 'Expr' to evaluate, so+-- nothing it could emit) stays plain 'Either' and is lifted at the call site.+liftEither :: Either EvalError a -> Eval a+liftEither = MkEval . fmap (,mempty)++-- | Records constraints reached by a @!@ (v3-symbols \S2.2), in the order+-- given.+tellConstraints :: [Value'] -> Eval ()+tellConstraints vs = MkEval (Right ((), mempty {emConstraints = vs}))++-- | Records one symbol-table entry, minted by an allocation or an+-- unsupplied demand at the root (\S1.3, \S5.2).+tellSymbol :: SymbolEntry -> Eval ()+tellSymbol entry = MkEval (Right ((), mempty {emSymbols = [entry]}))++-- | Maps over the error only, leaving any emissions already accumulated+-- alone -- 'InLibrary'\'s tag, applied the same way 'Data.Bifunctor.first'+-- tags a plain 'Either'.+mapEvalError :: (EvalError -> EvalError) -> Eval a -> Eval a+mapEvalError f (MkEval e) = MkEval (first f e)++foldlEval :: (b -> a -> Eval b) -> b -> [a] -> Eval b+foldlEval f = go+  where+    go acc [] = pure acc+    go acc (x : xs) = f acc x >>= \acc' -> go acc' xs++-- Entry points ---------------------------------------------------------------++-- | Evaluation now depends on the mode (v3-symbols \S5): an allocation or an+-- unsupplied root demand mints a symbol in symbolic mode and raises+-- 'SymbolsUnavailable' in concrete mode. There is no mode-independent+-- evaluation any more, so every entry point takes one.+evalProgram :: Mode -> LibraryTable -> Value -> Program -> Either EvalError Output+evalProgram mode libs input prog = fst <$> evalProgramWithEmissions mode libs input prog++-- | As 'evalProgram', but also returns the deduplicated 'Emissions'+-- (v3-symbols \S4) -- empty for any program that emits or allocates nothing,+-- and always empty in what concrete mode goes on to serialize, since+-- concrete mode discards them (\S5.1) and cannot produce a symbol at all.+evalProgramWithEmissions :: Mode -> LibraryTable -> Value -> Program -> Either EvalError (Output, Emissions)+evalProgramWithEmissions mode libs input prog = do+  erased <- first TypeErr (eraseTypes libs prog)+  (v, emitted) <- runEval $ do+    ctx <- liftEither (checkedFromJson mode input)+    let evalCtx = EvalCtx {ecLibs = libs, ecInProgress = Set.empty, ecMode = mode, ecIsRoot = True}+    evalExpr evalCtx (initialEnv ctx) (programRoot erased)+  output <- case v of+    VNode' n -> Right (ONode n)+    other -> OValue <$> toJson other+  pure (output, dedupe emitted)++-- | Two constraints with the same name and equal arguments are one+-- constraint, and two symbol-table entries with the same id are one entry --+-- each kept at the position of the first (v3-symbols \S4). Constraint+-- equality is on the already-evaluated 'Value'', which is why this must run+-- after evaluation rather than being folded into 'tellConstraints' -- two+-- constraints built from different expressions can still evaluate to the+-- same fact.+dedupe :: Emissions -> Emissions+dedupe (Emissions cs ss) = Emissions (dedupeBy constraintEq cs) (dedupeBy (\a b -> seId a == seId b) ss)+  where+    dedupeBy eq = go []+      where+        go _ [] = []+        go seen (x : xs)+          | any (eq x) seen = go seen xs+          | otherwise = x : go (x : seen) xs++-- | Structural equality restricted to what a constraint's identity is made+-- of: its name and its arguments, each compared as the JSON they will+-- render as. Two constraints are the same fact regardless of which+-- expressions produced them.+constraintEq :: Value' -> Value' -> Bool+constraintEq (VConstraint n1 as1) (VConstraint n2 as2) =+  n1 == n2 && length as1 == length as2 && and (zipWith argEq as1 as2)+  where+    argEq a b = case (toJson a, toJson b) of+      (Right ja, Right jb) -> ja == jb+      _ -> False+constraintEq _ _ = False++-- | The mode-aware entry point: what a host actually serializes. Concrete+-- mode is 'evalProgram' unchanged, projected down to plain JSON -- Node JSON+-- for a document, the value itself for an expression, with any emissions+-- discarded (v3-symbols \S5.1). Symbolic mode wraps the same 'Output' in the+-- v3 envelope (\S5.2), including the deduplicated symbol table and+-- constraint list.+runProgram :: Mode -> LibraryTable -> Value -> Program -> Either EvalError Value+runProgram mode libs input prog = do+  result <- evalProgramWithEmissions mode libs input prog+  typesInfo <- case mode of+    Concrete -> Right (Map.empty, [])+    Symbolic -> first TypeErr (buildTypesInfo libs prog)+  pure (renderOutput mode typesInfo result)++-- | The @\"types\"@ table's entries and the deduplicated @\"type-constraints\"@+-- list (v4-types \S8, roadmap Phase 13), computed from @prog@ /before/+-- erasure -- unlike evaluation, which never needs a 'TypeAnnotate' or+-- 'TypeEmit' once erasure has run, this is the one place they still matter:+-- the envelope is exactly where a host needs the definitions and constraints+-- those nodes named. Concrete mode never calls this ('runProgram' short-+-- circuits it), matching \S8's promise that a v3 consumer reading a v4+-- envelope sees nothing new.+buildTypesInfo :: LibraryTable -> Program -> Either TypeError (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])])+buildTypesInfo libs prog = do+  roots <- programTypeRoots libs prog+  closure <- typeClosure libs prog roots+  tcs <- deepTypeConstraints libs prog+  pure (closure, tcs)++renderOutput :: Mode -> (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])]) -> (Output, Emissions) -> Value+renderOutput Concrete _ (output, _) = case output of+  ONode n -> nodeToJson n+  OValue v -> v+renderOutput Symbolic (typesTable, typeConstraintsList) (output, Emissions constraints symbols) =+  Object+    ( KeyMap.fromList+        [ ("format", String "tramaj/symbolic/1")+        , ("kind", String kind)+        , ("root", root)+        , ("symbols", Array (V.fromList (map symbolEntryToJson symbols)))+        , ("constraints", Array (V.fromList (map constraintToJson constraints)))+        , ("types", Array (V.fromList (map typeEntryToJson (Map.toList typesTable))))+        , ("type-constraints", Array (V.fromList (map typeConstraintToJson typeConstraintsList)))+        ]+    )+  where+    (kind, root) = case output of+      ONode n -> ("document", nodeToJson n)+      OValue v -> ("expression", v)++-- | One @\"types\"@ table entry (v4-types \S8): the id, and the definition+-- behind it, rendered by 'resolvedTypeToJson'.+typeEntryToJson :: (Text, ResolvedType) -> Value+typeEntryToJson (tid, rt) =+  Object (KeyMap.fromList [("id", String tid), ("definition", resolvedTypeToJson rt)])++-- | A 'ResolvedType'\'s @\"definition\"@ shape (v4-types \S8's example): a+-- tagged union whose @kind@ names which of the six algebra shapes it is. A+-- 'RRef' renders as a pointer only -- its own definition is a separate entry+-- in the table, not inlined here -- which is \S3's "stop at declaration+-- boundaries" clause, still honoured at the JSON boundary.+resolvedTypeToJson :: ResolvedType -> Value+resolvedTypeToJson (RPrim name) = Object (KeyMap.fromList [("kind", String "prim"), ("name", String name)])+resolvedTypeToJson (RArray t) = Object (KeyMap.fromList [("kind", String "array"), ("element", resolvedTypeToJson t)])+resolvedTypeToJson (RRecord fields) =+  Object (KeyMap.fromList [("kind", String "record"), ("fields", Array (V.fromList (map field fields)))])+  where+    field (name, t) = Object (KeyMap.fromList [("name", String name), ("type", resolvedTypeToJson t)])+resolvedTypeToJson (RUnion arms) =+  Object (KeyMap.fromList [("kind", String "union"), ("arms", Array (V.fromList (map arm arms)))])+  where+    arm (name, mt) =+      Object (KeyMap.fromList (("name", String name) : maybe [] (\t -> [("payload", resolvedTypeToJson t)]) mt))+resolvedTypeToJson r@(RRef _ _ _) = Object (KeyMap.fromList [("kind", String "ref"), ("id", String (canonicalId r))])+resolvedTypeToJson (RVar path) = Object (KeyMap.fromList [("kind", String "var"), ("path", Array (V.fromList (map String path)))])++-- | A @\"type-constraints\"@ entry (v4-types \S8): a name and its resolved+-- arguments, a type argument rendered as the erased @{\"$type\": ...}@ tag+-- \S7 already reserves so a host reads both lists the same way, a scalar+-- argument as the plain JSON it already is.+typeConstraintToJson :: (Text, [ResolvedConstraintArg]) -> Value+typeConstraintToJson (name, args) =+  Object (KeyMap.fromList [("name", String name), ("arguments", Array (V.fromList (map arg args)))])+  where+    arg (RCType rt) = Object (KeyMap.fromList [("$type", String (canonicalId rt))])+    arg (RCScalarStr s) = String s+    arg (RCScalarNum n) = Number (fromFloatDigits n)+    arg (RCScalarBool b) = Bool b+    arg RCScalarNull = Null++-- | A constraint's envelope rendering (v3-symbols \S5.2): its name and its+-- arguments, each already-evaluated to plain JSON, an argument that is+-- itself a symbol rendering as \S5.3's @{"$sym": ..., "path": [...]}@ tag+-- via 'toJson'.+constraintToJson :: Value' -> Value+constraintToJson (VConstraint name args) =+  Object+    ( KeyMap.fromList+        [ ("name", String name)+        , ("arguments", Array (V.fromList (map (either (const Null) id . toJson) args)))+        ]+    )+constraintToJson other = either (const Null) id (toJson other)++-- | A symbol table entry's envelope rendering (\S5.2): id, origin (the+-- structured form of the id, so a host never has to parse it) and binding.+symbolEntryToJson :: SymbolEntry -> Value+symbolEntryToJson (SymbolEntry sid origin binding) =+  Object+    ( KeyMap.fromList+        [ ("id", String sid)+        , ("origin", originToJson origin)+        , ("binding", maybe Null String binding)+        ]+    )+  where+    originToJson (OAlloc site key) =+      Object (KeyMap.fromList [("kind", String "alloc"), ("site", Number (fromIntegral site)), ("key", key)])+    originToJson (ODemand path) =+      Object (KeyMap.fromList [("kind", String "demand"), ("path", Array (V.fromList (map String path)))])++-- | Evaluates one expression against a context value, with the builtins in+-- scope -- the shared path 'evalProgram' and library evaluation both take.+-- Any emissions reached are discarded; callers that need them should use+-- 'evalExpr' directly inside 'Eval'.+evalExprWith :: Mode -> LibraryTable -> Value' -> Expr -> Either EvalError Value'+evalExprWith mode libs ctx e =+  fst <$> runEval (evalExpr (EvalCtx {ecLibs = libs, ecInProgress = Set.empty, ecMode = mode, ecIsRoot = True}) (initialEnv ctx) e)++initialEnv :: Value' -> Env+initialEnv ctx = Map.insert "ctx" ctx (Map.fromList [(n, VBuiltin n) | n <- builtinNames])++-- | The fixed builtin vocabulary. Builtins are ordinary values in the initial+-- environment rather than a separate call form, so @cardinality($xs)@,+-- @$f($x)@ and @map($xs, $not)@ all go through 'Call'.+builtinNames :: [Text]+builtinNames =+  [ "cardinality"+  , "count"+  , "str"+  , "not"+  , "and"+  , "or"+  , "eq"+  , "lt"+  , "lte"+  , "gt"+  , "gte"+  , "has"+  , "lookup"+  , "concat"+  , "append"+  ]++-- Core evaluation ------------------------------------------------------------++evalExpr :: EvalCtx -> Env -> Expr -> Eval Value'+evalExpr ctx env (Path root fields) = case Map.lookup root env of+  Nothing -> evalError (UnboundName root)+  Just v -> walkFields ctx (root : fields) v fields+evalExpr ctx env (FieldAccess target fields) = do+  v <- evalExpr ctx env target+  walkFields ctx fields v fields+evalExpr ctx env (Call fnExpr argExprs) = do+  fnVal <- evalExpr ctx env fnExpr+  argVals <- traverse (evalExpr ctx env) argExprs+  apply ctx (describeCallee fnExpr) fnVal argVals+evalExpr _ env (Lambda params body) = pure (VClosure params body env)+-- | @\@name=?(k)@ or @\@name=?ctx.path@ binds the allocation\/demand directly+-- to a name, which is what the symbol table's @"binding"@ field (\S5.2)+-- reports; anything else evaluates exactly as it always has. Routed through+-- 'evalBindable' rather than special-cased here so a standalone 'Alloc'\/+-- 'Demand' (used inline, with no binding) shares the same minting logic.+evalExpr ctx env (Let name valueExpr body) = do+  v <- evalBindable ctx env (if isHiddenName name then Nothing else Just name) valueExpr+  evalExpr ctx (Map.insert name v env) body+evalExpr _ _ (StringLit s) = pure (VString s)+evalExpr _ _ (NumberLit n) = pure (VNumber (fromFloatDigits n))+evalExpr _ _ (BoolLit b) = pure (VBool b)+evalExpr _ _ NullLit = pure VNull+evalExpr ctx env (ArrayLit elems) =+  VArray <$> traverse (evalExpr ctx env) elems+evalExpr ctx env (ObjectLit entries) =+  VObject . Map.fromList <$> traverse (\(k, e) -> (,) k <$> evalExpr ctx env e) entries+evalExpr ctx env (Element tag attrs valExpr children) = do+  attrs' <- traverse (evalAttribute ctx env) attrs+  val <- evalExpr ctx env valExpr >>= liftEither . toJson+  children' <- evalChildren ctx env children+  pure (VNode' (NElement tag attrs' val children' noAnnotations))+evalExpr ctx env (Fragment children) =+  VNode' . flip NFragment noAnnotations <$> evalChildren ctx env children+-- | The one non-eager form in the language: the arm not selected is never+-- evaluated, so an error inside it never surfaces.+evalExpr ctx env (Branch condExpr thenExpr elseExpr) = do+  cond <- evalExpr ctx env condExpr >>= liftEither . requireBool "a branch condition"+  evalExpr ctx env (if cond then thenExpr else elseExpr)+evalExpr ctx env (Map collExpr fnExpr) = do+  items <- evalCollection ctx env "map" collExpr+  fnVal <- evalExpr ctx env fnExpr+  VArray <$> traverse (\item -> apply ctx "map" fnVal [item]) items+evalExpr ctx env (Filter collExpr fnExpr) = do+  items <- evalCollection ctx env "filter" collExpr+  fnVal <- evalExpr ctx env fnExpr+  kept <- traverse (\item -> (,) item <$> (apply ctx "filter" fnVal [item] >>= liftEither . requireBool "a filter predicate")) items+  pure (VArray [item | (item, True) <- kept])+evalExpr ctx env (Scan collExpr initExpr fnExpr) = do+  items <- evalCollection ctx env "scan" collExpr+  acc0 <- evalExpr ctx env initExpr+  fnVal <- evalExpr ctx env fnExpr+  VArray <$> scanSteps ctx fnVal acc0 items+evalExpr ctx env (Fold collExpr initExpr fnExpr) = do+  items <- evalCollection ctx env "fold" collExpr+  acc0 <- evalExpr ctx env initExpr+  fnVal <- evalExpr ctx env fnExpr+  foldSteps ctx fnVal acc0 items+evalExpr ctx env (Concat leftExpr rightExpr) = do+  l <- evalExpr ctx env leftExpr+  r <- evalExpr ctx env rightExpr+  liftEither (concatValues l r)+-- | Wiring up an import evaluates its parameters and stops there. The library+-- itself runs later, when a field is read off the result, so parameters can+-- keep arriving in between.+--+-- @ctx(path)@ is substituted here, from the /importing/ program's own context+-- -- exactly what @$ctx.path@ would read, including the same 'PathNotFound'+-- when it is absent, which is why it evaluates as that very expression. It is+-- a distinct AST node purely so "Tramaj.Analysis" can read every hole off the+-- source without evaluating anything; the evaluator gains nothing from the+-- distinction and deliberately makes no other use of it.+-- | A @%@-marked entry (v4-types \S2) supplies a type, not a value, so it+-- never reaches the library's own @$ctx@ -- 'resolveParam' drops it, the+-- same way 'pParams' never has a slot for it, rather than passing some inert+-- placeholder through: the two channels sharing one params record share no+-- runtime representation at all, one being erased entirely before+-- evaluation (\S7).+evalExpr ctx env (Import name params) = do+  supplied <- catMaybes <$> traverse resolveParam params+  pure (VImport (Pending name (Map.fromList supplied) []))+  where+    resolveParam (k, PExpr e) = Just . (,) k <$> evalExpr ctx env e+    resolveParam (k, PFromContext path) = Just . (,) k <$> evalExpr ctx env (Path "ctx" path)+    resolveParam (_, PType _) = pure Nothing+evalExpr ctx env (AdaptActions targetExpr adaptation fnExpr) = do+  target <- evalExpr ctx env targetExpr+  fnVal <- traverse (evalExpr ctx env) fnExpr+  adaptValue ctx adaptation fnVal target+-- | @constraint(name, args...)@ (v3-symbols \S2.1). Each argument must be+-- something that can cross a JSON boundary -- the same rule 'toJson' already+-- enforces everywhere else -- checked here and not deferred, since a+-- constraint carrying a closure would otherwise sit unnoticed until whatever+-- @!@ eventually reaches it, or never surface at all if none does.+evalExpr ctx env (Constrain name argExprs) = do+  argVals <- traverse (evalExpr ctx env) argExprs+  liftEither (traverse_ toJson argVals)+  pure (VConstraint name argVals)+-- | @!expr@ (\S2.2): evaluates the constraint expression, collects from its+-- value by the coercion table 'collectConstraints' encodes, records what it+-- collected, then continues into the body -- the same "earlier bindings+-- only" shape 'Let' already has, since both nest into one chain.+evalExpr ctx env (Emit constraintExpr body) = do+  cv <- evalExpr ctx env constraintExpr+  collected <- liftEither (collectConstraints cv)+  tellConstraints collected+  evalExpr ctx env body+evalExpr ctx env e@(Alloc _ _) = evalBindable ctx env Nothing e+evalExpr ctx env e@(Demand _) = evalBindable ctx env Nothing e+-- | @type Name = TypeExpr@ (v4-types \S1.1, roadmap Phase 8): means nothing+-- to evaluation -- resolution is a static pass (v4-types \S9) -- so this+-- simply continues into the body.+evalExpr ctx env (TypeDecl _ _ body) = evalExpr ctx env body+-- | Every entry point below ('evalProgramWithEmissions', 'runLibrary') runs+-- "Tramaj.Types"\'s erasure pass before ever calling 'evalExpr', which+-- rewrites every 'TypeAnnotate' into the 'Let'\/'Emit' pair v4-types \S7+-- specifies -- so this case is not the normal path. It is kept total anyway,+-- exactly as 'TypeDecl'\'s case is total on purpose: matching what erasure+-- would have produced, minus the emission, keeps 'evalExpr' correct even if+-- a caller somehow reaches it pre-erasure, rather than leaving a partial+-- match for that case to crash on.+evalExpr ctx env (TypeAnnotate name _ valueExpr body) = evalExpr ctx env (Let name valueExpr body)+-- | @!type-constraint(...)@ (v4-types \S5, roadmap Phase 12): resolved by+-- the analyser, never evaluated -- \S5.1 is explicit that the evaluator's+-- statement fold skips this, exactly as it skips 'TypeDecl'.+evalExpr ctx env (TypeEmit _ _ body) = evalExpr ctx env body++-- | 'Alloc' and 'Demand' are the two forms whose symbol-table entry records+-- the name they were bound to, or 'Nothing' when used inline (v3-symbols+-- \S5.2's @"binding"@ field) -- everything else evaluates through plain+-- 'evalExpr', unaffected by whether it happens to sit on a 'Let'\'s+-- right-hand side.+evalBindable :: EvalCtx -> Env -> Maybe Text -> Expr -> Eval Value'+evalBindable ctx env binding (Alloc site keyExpr) = evalAlloc ctx env binding site keyExpr+evalBindable ctx env binding (Demand path) = evalDemand ctx env binding path+evalBindable ctx env _ other = evalExpr ctx env other++-- | @?(key)@ (\S1.2, \S4): the key is evaluated first, in both modes alike --+-- so an error inside it surfaces the same way regardless of mode -- and+-- only /minting/ depends on the mode (\S5.1): concrete mode has no way to+-- represent the result, symbolic mode allocates and records the entry.+evalAlloc :: EvalCtx -> Env -> Maybe Text -> Int -> Expr -> Eval Value'+evalAlloc ctx env binding site keyExpr = do+  keyVal <- evalExpr ctx env keyExpr+  keyJson <- liftEither (requireConcrete "?(...)" keyVal)+  case ecMode ctx of+    Concrete -> evalError SymbolsUnavailable+    Symbolic -> do+      let sid = "#" <> tshow site <> ":" <> canon keyJson+      tellSymbol (SymbolEntry sid (OAlloc site keyJson) binding)+      pure (VSymbol sid [])++-- | @?ctx.a.b@ (\S1.3): reads exactly as @$ctx.a.b@ would when the path is+-- supplied, in either mode -- 'tryEval' only ever looks past a+-- 'PathNotFound' it raises. Unsupplied, it allocates at the root (mode+-- permitting) and is an ordinary unsupplied read anywhere else, which+-- 'mapEvalError' in 'runLibrary' already tags with 'InLibrary'.+evalDemand :: EvalCtx -> Env -> Maybe Text -> [Text] -> Eval Value'+evalDemand ctx env binding path = do+  attempt <- tryEval (evalExpr ctx env (Path "ctx" path))+  case attempt of+    Right v -> pure v+    Left (PathNotFound _) | ecIsRoot ctx -> case ecMode ctx of+      Concrete -> evalError SymbolsUnavailable+      Symbolic -> do+        let sid = "#ctx" <> mconcat (map ("." <>) path)+        tellSymbol (SymbolEntry sid (ODemand path) binding)+        pure (VSymbol sid [])+    Left e -> evalError e++-- | Runs an 'Eval' computation and reports whether it failed, without+-- discarding whatever it had already accumulated on success. Used only to+-- look past a 'PathNotFound' that might mean "allocate instead" -- every+-- other error still propagates once inspected.+tryEval :: Eval a -> Eval (Either EvalError a)+tryEval (MkEval e) = MkEval $ case e of+  Left err -> Right (Left err, mempty)+  Right (a, w) -> Right (Right a, w)++-- | The coercion table a @!@ collects by (v3-symbols \S2.2): a constraint+-- contributes itself; an array contributes each element, recursively, which+-- is why @!map(...)@ and @!$cs@ (a binding holding an array built earlier)+-- both read naturally; anything else is a 'TypeMismatch'.+collectConstraints :: Value' -> Either EvalError [Value']+collectConstraints v@(VConstraint _ _) = Right [v]+collectConstraints (VArray xs) = concat <$> traverse collectConstraints xs+collectConstraints other = Left (TypeMismatch ("! expects a constraint or an array of them, got " <> describeValue other))++-- | Only for error messages: what the source called, as written.+describeCallee :: Expr -> Text+describeCallee (Path root fields) = T.intercalate "." (root : fields)+describeCallee _ = "a call"++-- Documents -------------------------------------------------------------------++evalAttribute :: EvalCtx -> Env -> Attribute -> Eval NodeAttribute+evalAttribute ctx env (Attr name e) = NAttr name <$> (evalExpr ctx env e >>= liftEither . toJson)+evalAttribute ctx env (ActionAttr event key payloadExpr) =+  NAction event key <$> (evalExpr ctx env payloadExpr >>= liftEither . toJson)++evalChildren :: EvalCtx -> Env -> [Expr] -> Eval [Node]+evalChildren ctx env children =+  concat <$> traverse (\e -> evalExpr ctx env e >>= liftEither . childNodes) children++-- | How a value becomes children. A node is itself one child; an array+-- contributes each of its elements, which is how @map(...)@ produces repeated+-- siblings without a document-specific map form; anything else becomes a text+-- node carrying that value unconverted, so a number child stays a number.+--+-- A closure, an unfinished import or a constraint has no rendering, and+-- 'toJson' says so -- a 'VConstraint' reaching here is exactly \S2.1's rule+-- that a constraint MUST NOT cross a JSON boundary, including as a child.+childNodes :: Value' -> Either EvalError [Node]+childNodes (VNode' n) = Right [n]+childNodes (VArray xs) = concat <$> traverse childNodes xs+childNodes v = (\j -> [NText j noAnnotations]) <$> toJson v++-- Application ------------------------------------------------------------------++apply :: EvalCtx -> Text -> Value' -> [Value'] -> Eval Value'+apply ctx _ (VClosure params body closureEnv) args+  | length params /= length args =+      evalError (TypeMismatch ("closure expects " <> tshow (length params) <> " argument(s), got " <> tshow (length args)))+  | otherwise =+      evalExpr ctx (foldl' (\e (p, v) -> Map.insert p v e) closureEnv (zip params args)) body+apply _ _ (VBuiltin name) args = liftEither (evalBuiltin name args)+-- | Saturating an import: the argument is more parameters, merged over what it+-- already has. Right-biased, like @\<\>@ on objects, so a later call overrides+-- an earlier value for the same name -- which is what makes one wired-up+-- import reusable across a @map@, each iteration supplying its own.+apply _ who (VImport pending) args = case args of+  [VObject more] -> pure (VImport pending {pParams = Map.union more (pParams pending)})+  [other] ->+    evalError+      ( TypeMismatch+          (who <> ": the import of " <> tshow (pName pending) <> " takes an object of parameters, got " <> describeValue other)+      )+  _ -> evalError (TypeMismatch (who <> ": the import of " <> tshow (pName pending) <> " expects exactly 1 argument, the parameters to add"))+apply _ who v _ = evalError (TypeMismatch (who <> " is not callable: " <> describeValue v))++-- | @scan@'s output is @[init, f(init, x1), f(f(init, x1), x2), ...]@ --+-- @scanl@, not @scanl1@.+scanSteps :: EvalCtx -> Value' -> Value' -> [Value'] -> Eval [Value']+scanSteps _ _ acc [] = pure [acc]+scanSteps ctx fnVal acc (item : rest) = do+  next <- apply ctx "scan" fnVal [acc, item]+  (acc :) <$> scanSteps ctx fnVal next rest++-- | The same steps as 'scanSteps', keeping only the final accumulator.+foldSteps :: EvalCtx -> Value' -> Value' -> [Value'] -> Eval Value'+foldSteps _ _ acc [] = pure acc+foldSteps ctx fnVal acc (item : rest) = do+  next <- apply ctx "fold" fnVal [acc, item]+  foldSteps ctx fnVal next rest++evalCollection :: EvalCtx -> Env -> Text -> Expr -> Eval [Value']+evalCollection ctx env who e =+  evalExpr ctx env e >>= \case+    VArray xs -> pure xs+    VSymbol _ _ -> evalError (NotConcrete who)+    other -> evalError (TypeMismatch (who <> " expects an array as its first argument, got " <> describeValue other))++-- Concat -------------------------------------------------------------------------++-- | The monoid operation over the three types that have one. Mixed types are+-- an error rather than a coercion, and objects merge right-biased. Either+-- side being a symbol is 'NotConcrete' (v3-symbols \S1.5), ahead of the+-- generic mismatch: the spine of a concatenation must be known, unlike an+-- element it might merely carry.+concatValues :: Value' -> Value' -> Either EvalError Value'+concatValues (VSymbol _ _) _ = Left (NotConcrete "<>")+concatValues _ (VSymbol _ _) = Left (NotConcrete "<>")+concatValues (VString a) (VString b) = Right (VString (a <> b))+concatValues (VArray a) (VArray b) = Right (VArray (a <> b))+concatValues (VObject a) (VObject b) = Right (VObject (Map.union b a))+concatValues l r = Left (ConcatMismatch (describeValue l) (describeValue r))++-- Imports --------------------------------------------------------------------------++-- | Runs the library behind an import, against the parameters it has+-- accumulated, and applies whatever adaptations were queued on it.+--+-- This is the only place a library runs, and 'walkFields' is the only caller:+-- an import runs when a field is read off it, never where it is written.+-- Nothing checks first whether the parameters are enough -- there is no list+-- of what "enough" would be. A library that reads a @$ctx@ path nobody+-- supplied fails with its own 'PathNotFound', tagged by 'runLibrary' with the+-- library's name.+forceImport :: EvalCtx -> Pending -> Eval Value'+forceImport ctx pending = do+  result <- runLibrary ctx (pName pending) (VObject (pParams pending))+  applyQueued ctx (pQueued pending) result++-- | Evaluates a library against its own fresh @$ctx@ -- the parameters it was+-- given -- and exposes @{rendered, vals}@. @inProgress@ carries the libraries+-- already being evaluated on this chain, so re-entering one is reported as a+-- cycle instead of running forever.+--+-- Bindings are replayed by hand, via 'foldlEval' over 'bindStep', rather than+-- letting a single 'evalExpr' over the whole chain produce @rendered@:+-- that is what exposes each binding's own value for @.vals@ without a+-- separate environment-inspection mechanism. Any @!@ interleaved among the+-- bindings (v3-symbols \S2.3 -- "a library's emissions are collected ... when+-- a field is read off its import") is replayed the same way, in the same+-- pass, so its constraints are collected exactly once, at its position in+-- the chain -- this is the fix for the 'unlets' trap: the old version simply+-- stopped at the first non-'Let', which silently dropped both the bindings+-- after a @!@ and the @!@'s own constraint.+runLibrary :: EvalCtx -> Text -> Value' -> Eval Value'+runLibrary ctx name ctxVal+  | Set.member name (ecInProgress ctx) = evalError (ImportCycle name)+  | otherwise = do+      rawProg <- liftEither (maybe (Left (UnknownLibrary name)) Right (Map.lookup name (ecLibs ctx)))+      liftEither (if Set.null (symbolSites rawProg) then Right () else Left (AllocationInLibrary name))+      prog <- liftEither (first TypeErr (eraseTypes (ecLibs ctx) rawProg))+      mapEvalError (InLibrary name) $ do+        let ctx' = enterLibrary name ctx+            (statements, root) = unlets (programRoot prog)+        libEnv <- foldlEval (bindStep ctx') (initialEnv ctxVal) statements+        rendered <- evalExpr ctx' libEnv root+        let bindings = filter (not . isHiddenName . fst) (letBindings statements)+        pure (VEnv (Map.fromList [("rendered", rendered), ("vals", VEnv (Map.fromList (map (\(n, _) -> (n, libEnv Map.! n)) bindings)))]))+  where+    bindStep ctx' env (SLet n e) = do+      v <- evalExpr ctx' env e+      pure (Map.insert n v env)+    bindStep ctx' env (SEmit e) = do+      cv <- evalExpr ctx' env e+      collected <- liftEither (collectConstraints cv)+      tellConstraints collected+      pure env+    -- | A type declaration means nothing to the evaluator (v4-types, roadmap+    -- Phase 8) -- it exists for static resolution alone, so replaying it here+    -- is a no-op on the environment.+    bindStep _ env (STypeDecl _ _) = pure env+    -- | See 'evalExpr'\'s 'TypeAnnotate' case: erasure has already turned+    -- this into a 'SLet' plus 'SEmit' by the time a library's own chain gets+    -- here, so this branch, like that one, only guards totality.+    bindStep ctx' env (SAnnotate n _ e) = do+      v <- evalExpr ctx' env e+      pure (Map.insert n v env)+    -- | See 'evalExpr'\'s 'TypeEmit' case: never evaluated.+    bindStep _ env (STypeEmit _ _) = pure env++-- Action adaptation -------------------------------------------------------------------++-- | Applies an adaptation everywhere it can reach: through a node's whole+-- tree, through every value of an import result (not just @rendered@), and+-- through arrays. An import that has not run has no actions yet, so the+-- adaptation is queued and runs on its result. Anything else has no actions+-- and passes through untouched.+adaptValue :: EvalCtx -> ActionAdaptation -> Maybe Value' -> Value' -> Eval Value'+adaptValue ctx adaptation fnVal = go+  where+    go (VNode' n) = VNode' <$> mapActions (adaptAction ctx adaptation fnVal) n+    go (VEnv e) = VEnv <$> traverse go e+    go (VArray xs) = VArray <$> traverse go xs+    go (VObject o) = VObject <$> traverse go o+    go (VImport pending) = pure (VImport pending {pQueued = pQueued pending <> [(adaptation, fnVal)]})+    go v = pure v++applyQueued :: EvalCtx -> [(ActionAdaptation, Maybe Value')] -> Value' -> Eval Value'+applyQueued ctx queued v0 =+  foldlEval (\v (adaptation, fnVal) -> adaptValue ctx adaptation fnVal v) v0 queued++-- | One action, adapted. The key is rewritten first, unconditionally, by the+-- static adaptation; the optional closure then sees the already-adapted action+-- and may change only its event type and payload. A @key@ in the closure's+-- result is ignored -- letting it win would put the action vocabulary back+-- beyond static reach, which is the whole point of restricting adaptation.+adaptAction :: EvalCtx -> ActionAdaptation -> Maybe Value' -> Text -> Text -> Value -> Eval NodeAttribute+adaptAction ctx adaptation fnVal event key payload =+  case fnVal of+    Nothing -> pure (NAction event key' payload)+    Just fn -> do+      result <- apply ctx "adapt-actions" fn [actionAsValue] >>= liftEither . toJson+      case result of+        Object obj -> do+          event' <- liftEither $ case KeyMap.lookup (Key.fromText "eventType") obj of+            Just (String s) -> Right s+            _ -> Left (TypeMismatch "adapt-actions: the function's result needs a string \"eventType\" field")+          let payload' = maybe Null id (KeyMap.lookup (Key.fromText "payload") obj)+          pure (NAction event' key' payload')+        _ -> evalError (TypeMismatch "adapt-actions: the function must return an object with an eventType field")+  where+    key' = adaptKey adaptation key+    actionAsValue =+      VObject+        (Map.fromList [("eventType", VString event), ("key", VString key'), ("payload", fromJson payload)])++-- Paths and fields -----------------------------------------------------------------------++-- | Walks named segments into a value. @context@ is the full path as written,+-- for error messages only.+walkFields :: EvalCtx -> [Text] -> Value' -> [Text] -> Eval Value'+walkFields _ _ v [] = pure v+walkFields ctx context v fields@(field : rest) = case v of+  VObject o -> case Map.lookup field o of+    Nothing -> evalError (PathNotFound context)+    Just v' -> walkFields ctx context v' rest+  VEnv e -> case Map.lookup field e of+    Nothing -> evalError (PathNotFound context)+    Just v' -> walkFields ctx context v' rest+  -- Reading a field off an import is what runs it -- @.rendered@ and @.vals@+  -- are fields of the result, so the same segment is then walked into that+  -- result rather than consumed here.+  VImport pending -> do+    result <- forceImport ctx pending+    walkFields ctx context result fields+  -- Projection (v3-symbols \S1.6): reads nothing, and is never rejected --+  -- whether the thing a symbol stands for has this field is a question for+  -- whoever owns its meaning, not the language. Consumes every remaining+  -- segment at once, since a projection just extends the path.+  VSymbol sid path -> pure (VSymbol sid (path <> fields))+  other ->+    evalError+      ( TypeMismatch+          ("cannot read field " <> tshow field <> " of " <> describeValue other <> " in path " <> tshow (T.intercalate "." context))+      )++-- Conversion ------------------------------------------------------------------------------++-- | Down to JSON, at the boundaries where only JSON is meaningful: an+-- attribute value, an action payload, an element's value slot, an expression+-- program's result.+--+-- The values that cannot cross say why. A node is deliberately included:+-- documents nest as children, not as attribute values, and silently+-- serializing one here would hide a mistake rather than report it.+toJson :: Value' -> Either EvalError Value+toJson VNull = Right Null+toJson (VBool b) = Right (Bool b)+toJson (VNumber n) = Right (Number n)+toJson (VString s) = Right (String s)+toJson (VArray xs) = Array . V.fromList <$> traverse toJson xs+toJson (VObject o) = Object . KeyMap.fromList <$> traverse (\(k, v) -> (,) (Key.fromText k) <$> toJson v) (Map.toList o)+toJson (VNode' _) = Left (TypeMismatch "a document node is not a plain value -- nest it as a child rather than using it where a value is expected")+toJson (VConstraint name _) = Left (TypeMismatch ("a constraint (" <> tshow name <> ") cannot cross a JSON boundary -- only \"!\" may consume it"))+-- | A symbol may sit in an attribute, a payload, a value slot or a text+-- child (v3-symbols \S1.5), so this always succeeds -- it is 'requireConcrete'+-- that refuses one, for the handful of forms that need to. \S5.3's tagged+-- shape: both fields required, matching what the decoder in+-- 'checkedFromJson' accepts back.+toJson (VSymbol sid path) =+  Right (Object (KeyMap.fromList [("$sym", String sid), ("path", Array (V.fromList (map String path)))]))+toJson (VClosure _ _ _) = Left (TypeMismatch "expected a value, got a function -- call it first, e.g. $my-fn(...)")+toJson (VBuiltin name) = Left (TypeMismatch ("expected a value, got the builtin " <> tshow name <> " -- call it first"))+toJson (VEnv _) = Left (TypeMismatch "expected a value, got an import result -- read .rendered, .vals, or a binding name from it first")+toJson (VImport pending) =+  Left+    ( TypeMismatch+        ( "expected a value, got the import of "+            <> tshow (pName pending)+            <> " -- read .rendered or .vals from it to run it first"+        )+    )++fromJson :: Value -> Value'+fromJson Null = VNull+fromJson (Bool b) = VBool b+fromJson (Number n) = VNumber n+fromJson (String s) = VString s+fromJson (Array arr) = VArray (map fromJson (V.toList arr))+fromJson (Object obj) = VObject (Map.fromList (map (\(k, v) -> (Key.toText k, fromJson v)) (KeyMap.toList obj)))++-- | The input context's boundary: as 'fromJson', but recursively refusing+-- @"$sym"@ and @"$type"@ as ordinary object keys (v3-symbols \S5.3). In+-- concrete mode either key is refused unconditionally. In symbolic mode,+-- seeding (\S5.4) accepts a well-formed @{"$sym": ..., "path": [...]}@ back+-- as an actual symbol -- anything else carrying @"$sym"@, or @"$type"@ at+-- all (v3 has no valid shape for it yet), is still refused.+checkedFromJson :: Mode -> Value -> Either EvalError Value'+checkedFromJson _ Null = Right VNull+checkedFromJson _ (Bool b) = Right (VBool b)+checkedFromJson _ (Number n) = Right (VNumber n)+checkedFromJson _ (String s) = Right (VString s)+checkedFromJson mode (Array arr) = VArray <$> traverse (checkedFromJson mode) (V.toList arr)+checkedFromJson mode (Object obj)+  | KeyMap.member (Key.fromText "$type") obj =+      Left (TypeMismatch "the context carries the reserved key \"$type\", which only a typed envelope may use")+  | Just symVal <- KeyMap.lookup (Key.fromText "$sym") obj =+      case mode of+        Concrete -> Left (TypeMismatch "the context carries the reserved key \"$sym\", which only a symbolic envelope may use")+        Symbolic -> case (symVal, KeyMap.toList (KeyMap.delete (Key.fromText "$sym") obj)) of+          (String sid, [("path", Array pathArr)]) -> do+            path <- traverse expectString (V.toList pathArr)+            Right (VSymbol sid path)+          _ -> Left (TypeMismatch "a \"$sym\" object must be exactly {\"$sym\": <id>, \"path\": [<segment>, ...]}")+  | otherwise =+      VObject . Map.fromList <$> traverse (\(k, v) -> (,) (Key.toText k) <$> checkedFromJson mode v) (KeyMap.toList obj)+  where+    expectString (String s) = Right s+    expectString _ = Left (TypeMismatch "a symbol reference's \"path\" must be an array of strings")++describeValue :: Value' -> Text+describeValue VNull = "null"+describeValue (VBool _) = "a boolean"+describeValue (VNumber _) = "a number"+describeValue (VString _) = "a string"+describeValue (VArray _) = "an array"+describeValue (VObject _) = "an object"+describeValue (VNode' _) = "a document node"+describeValue (VClosure _ _ _) = "a function"+describeValue (VBuiltin name) = "the builtin " <> tshow name+describeValue (VEnv _) = "an import result"+describeValue (VImport pending) = "the not-yet-run import of " <> tshow (pName pending)+describeValue (VConstraint name _) = "a constraint (" <> tshow name <> ")"+describeValue (VSymbol _ _) = "a symbol"++-- | Control flow must be concrete (v3-symbols \S1.5): a symbolic condition is+-- 'NotConcrete', not merely the wrong type.+requireBool :: Text -> Value' -> Either EvalError Bool+requireBool _ (VBool b) = Right b+requireBool who (VSymbol _ _) = Left (NotConcrete who)+requireBool who other = Left (TypeMismatch (who <> " must be a boolean, got " <> describeValue other))++-- | Whether a value is, or contains, a symbol -- what makes a value+-- concrete's negation (\S1.5, \S1.7): a structure built of concrete pieces is+-- itself concrete and every structural operation on it works as normal;+-- only a symbol itself, wherever it sits, makes the whole not concrete.+containsSymbol :: Value' -> Bool+containsSymbol (VSymbol _ _) = True+containsSymbol (VArray xs) = any containsSymbol xs+containsSymbol (VObject o) = any containsSymbol (Map.elems o)+containsSymbol _ = False++-- | Requires a value with no symbol anywhere in it, for the handful of+-- operations \S1.5 lists as needing to *know* something about their+-- argument rather than merely carry it: @str@, @eq@, and an allocation key.+-- Everything else about crossing a JSON boundary is 'toJson'\'s ordinary+-- business, which this defers to once a symbol is ruled out.+requireConcrete :: Text -> Value' -> Either EvalError Value+requireConcrete who v+  | containsSymbol v = Left (NotConcrete who)+  | otherwise = toJson v++-- | v3-symbols \S1.4: compact JSON with keys sorted, agreeing with @str@ on+-- arrays and objects and differing at the top level for strings, where+-- @str@ renders raw and this quotes -- the difference that makes it+-- injective. This is exactly 'compactJson', which already quotes a string+-- unconditionally; the two are one function under two names because they+-- serve the same requirement (\S1.4's canon, \S6's @str@) for the same+-- reason.+canon :: Value -> Text+canon = compactJson++tshow :: (Show a) => a -> Text+tshow = T.pack . show++-- Builtins ------------------------------------------------------------------------------------++-- | A fixed vocabulary, grown only on real demand. @branch@ is absent+-- deliberately: it has to leave an arm unevaluated, which no builtin can do,+-- so it is a core constructor instead.+evalBuiltin :: Text -> [Value'] -> Either EvalError Value'+evalBuiltin name args = case name of+  "cardinality" -> cardinality+  "count" -> cardinality+  "str" -> arity1 (fmap (VString . displayString) . requireConcrete name)+  "not" -> arity1 (fmap (VBool . not) . asBool)+  "and" -> variadicBool (&&) True+  "or" -> variadicBool (||) False+  "eq" -> binary (\a b -> VBool <$> ((==) <$> requireConcrete name a <*> requireConcrete name b))+  "lt" -> comparison (<)+  "lte" -> comparison (<=)+  "gt" -> comparison (>)+  "gte" -> comparison (>=)+  "has" -> binary hasImpl+  "lookup" -> ternary lookupImpl+  "concat" -> concatImpl+  "append" -> binary appendImpl+  _ -> Left (UnboundName name)+  where+    arity1 :: (Value' -> Either EvalError a) -> Either EvalError a+    arity1 f = case args of+      [a] -> f a+      _ -> Left (TypeMismatch (name <> " expects exactly 1 argument, got " <> tshow (length args)))++    binary :: (Value' -> Value' -> Either EvalError Value') -> Either EvalError Value'+    binary f = case args of+      [a, b] -> f a b+      _ -> Left (TypeMismatch (name <> " expects exactly 2 arguments, got " <> tshow (length args)))++    ternary :: (Value' -> Value' -> Value' -> Either EvalError Value') -> Either EvalError Value'+    ternary f = case args of+      [a, b, c] -> f a b c+      _ -> Left (TypeMismatch (name <> " expects exactly 3 arguments, got " <> tshow (length args)))++    cardinality :: Either EvalError Value'+    cardinality = arity1 $ \case+      VArray xs -> Right (VNumber (fromIntegral (length xs)))+      VObject o -> Right (VNumber (fromIntegral (Map.size o)))+      VSymbol _ _ -> Left (NotConcrete name)+      other -> Left (TypeMismatch (name <> " expects an array or object, got " <> describeValue other))++    asBool :: Value' -> Either EvalError Bool+    asBool (VBool b) = Right b+    asBool other = Left (TypeMismatch (name <> " expects a boolean argument, got " <> describeValue other))++    asNumber :: Value' -> Either EvalError Scientific+    asNumber (VNumber n) = Right n+    asNumber (VSymbol _ _) = Left (NotConcrete name)+    asNumber other = Left (TypeMismatch (name <> " expects a number argument, got " <> describeValue other))++    asArray :: Value' -> Either EvalError [Value']+    asArray (VArray xs) = Right xs+    asArray other = Left (TypeMismatch (name <> " expects an array argument, got " <> describeValue other))++    -- | @and@\/@or@ fold over however many arguments they are given, zero+    -- included (vacuously), rather than fixing an arity.+    variadicBool :: (Bool -> Bool -> Bool) -> Bool -> Either EvalError Value'+    variadicBool op identityVal = VBool . foldl' op identityVal <$> traverse asBool args++    comparison :: (Scientific -> Scientific -> Bool) -> Either EvalError Value'+    comparison op = binary $ \a b -> VBool <$> (op <$> asNumber a <*> asNumber b)++    -- | Deliberately tolerant: a missing key, an out-of-range index, or a+    -- container of the wrong shape all answer @false@ rather than erroring+    -- -- except a symbolic container, which is 'NotConcrete' rather than a+    -- lie (v3-symbols \S1.5): the tolerant @false@ would claim to know+    -- something about a container the language cannot see into.+    hasImpl :: Value' -> Value' -> Either EvalError Value'+    hasImpl (VSymbol _ _) _ = Left (NotConcrete name)+    hasImpl container key = Right . VBool $ case (container, key) of+      (VObject o, VString k) -> Map.member k o+      (VArray xs, VNumber n) -> maybe False (\i -> i >= 0 && i < length xs) (asIndex n)+      _ -> False++    -- | Dynamic access by a computed key or index -- the counterpart to a+    -- static path segment. The third argument is the mandatory fallback. A+    -- symbolic container is 'NotConcrete' rather than falling back, which+    -- would silently discard the symbol (\S1.5).+    lookupImpl :: Value' -> Value' -> Value' -> Either EvalError Value'+    lookupImpl (VSymbol _ _) _ _ = Left (NotConcrete name)+    lookupImpl container key fallback = Right $ case (container, key) of+      (VObject o, VString k) -> maybe fallback id (Map.lookup k o)+      (VArray xs, VNumber n) -> maybe fallback id (asIndex n >>= atIndex xs)+      _ -> fallback++    atIndex :: [Value'] -> Int -> Maybe Value'+    atIndex xs i+      | i >= 0 && i < length xs = Just (xs !! i)+      | otherwise = Nothing++    -- | An index must be a non-negative whole number: @2.5@ and @-1@ are not+    -- indices.+    asIndex :: Scientific -> Maybe Int+    asIndex n =+      let d = toRealFloat n :: Double+          i = round d :: Int+       in if fromIntegral i == d && i >= 0 then Just i else Nothing++    -- | Variadic array join, preserving order. @concat()@ is @[]@; a+    -- non-array argument anywhere is an error rather than being wrapped.+    concatImpl :: Either EvalError Value'+    concatImpl = VArray . concat <$> traverse asArray args++    -- | @append(arr, item)@ adds one element at the end. An array item is+    -- appended as a single element, not spliced -- @concat@ splices.+    appendImpl :: Value' -> Value' -> Either EvalError Value'+    appendImpl arr item = (\xs -> VArray (xs <> [item])) <$> asArray arr++-- | How a value reads when it is rendered into a string by @str@ (and so by+-- string interpolation): a string is itself, @null@ is empty, and anything+-- structured is compact JSON.+--+-- This is a normative rendering, not a debugging one, so it must agree+-- across implementations character for character -- it is what a template+-- interpolates into its output. See @../specs/reference.md@.+displayString :: Value -> Text+displayString Null = ""+displayString (Bool b) = if b then "true" else "false"+displayString (Number n) = formatNumber n+displayString (String s) = s+displayString v = compactJson v++-- | Compact JSON, with object keys in sorted order and numbers formatted by+-- 'formatNumber'.+--+-- Deliberately not aeson's own 'encode': that writes every number through+-- its 'Scientific' representation (@1.0@, @1.0e11@) where a JavaScript host+-- writes @1@ and @100000000000@, so using it here would leave two+-- conforming implementations rendering the same value differently. Keys are+-- sorted for the same reason -- object key order is not semantically+-- significant, so it must not be observable through @str@ either.+compactJson :: Value -> Text+compactJson Null = "null"+compactJson (Bool b) = if b then "true" else "false"+compactJson (Number n) = formatNumber n+compactJson (String s) = quoteString s+compactJson (Array xs) = "[" <> T.intercalate "," (map compactJson (V.toList xs)) <> "]"+compactJson (Object o) =+  "{" <> T.intercalate "," (map entry (sortOn fst (map (\(k, v) -> (Key.toText k, v)) (KeyMap.toList o)))) <> "}"+  where+    entry (k, v) = quoteString k <> ":" <> compactJson v++-- | A JSON string literal, escaped by aeson itself so this does not grow a+-- second, subtly different escaping table.+quoteString :: Text -> Text+quoteString = TL.toStrict . TLE.decodeUtf8 . encode . String++formatNumber :: Scientific -> Text+formatNumber = formatDouble . toRealFloat++-- | Formats a double exactly as ECMAScript's @Number::toString@ does.+--+-- Matching that specific algorithm is the point: the PureScript+-- implementation runs on a JavaScript host, where this is simply what a+-- number's text /is/. Haskell's own 'show' picks different thresholds for+-- scientific notation -- @0.05@ prints as @5.0e-2@, @1e11@ as @1.0e11@ --+-- so leaving it to 'show' would make the two implementations disagree on+-- something as ordinary as interpolating a price or a count.+--+-- NaN and infinities cannot reach here: JSON has no way to express them.+formatDouble :: Double -> Text+formatDouble d+  | isNaN d = "NaN"+  | isInfinite d = if d < 0 then "-Infinity" else "Infinity"+  | d == 0 = "0"+  | d < 0 = "-" <> formatPositive (negate d)+  | otherwise = formatPositive d++-- | The digit-placement rules of ECMA-262's @Number::toString@, given the+-- shortest round-tripping digit sequence @ds@ and exponent @n@ for which+-- the value is @0.ds * 10^n@ -- which is exactly what 'floatToDigits'+-- returns.+formatPositive :: Double -> Text+formatPositive d+  | n >= k && n <= 21 = digits <> T.replicate (n - k) "0"+  | n > 0 && n <= 21 = T.take n digits <> "." <> T.drop n digits+  | n > (-6) && n <= 0 = "0." <> T.replicate (negate n) "0" <> digits+  | otherwise = mantissa <> "e" <> sign <> tshow (abs e)+  where+    (ds, n) = floatToDigits 10 d+    k = length ds+    digits = T.pack (map intToDigit ds)+    e = n - 1+    mantissa = if k == 1 then digits else T.take 1 digits <> "." <> T.drop 1 digits+    sign = if e >= 0 then "+" else "-" :: Text

@@ -0,0 +1,183 @@+-- | The evaluated document representation -- Tramaj's output domain and its+-- portable interchange boundary. 'nodeToJson'\/'nodeFromJson' implement the+-- normative representation specified in @../specs/node-json.md@; that+-- document, not this module, is the contract other implementations and hosts+-- are held to.+--+-- Deliberately independent of both the expression AST ("Tramaj.Ast") and of+-- any particular render target: a host folds a 'Node' into HTML, a UI tree,+-- YAML, HCL or anything else on its own terms.+module Tramaj.Node+  ( Node (..)+  , NodeAttribute (..)+  , Annotations+  , noAnnotations+  , nodeToJson+  , nodeFromJson+  , nodeAttributeToJson+  , mapActions+  ) where++import Data.Aeson (Value (..), object, (.=))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Vector as V++-- | Arbitrary host\/tooling metadata hung off any node. The core language+-- assigns no meaning to any key; unknown annotations must not affect+-- semantics, and every node-to-node transformation must carry them through+-- unchanged. This is where a future type\/domain\/constraint pass puts what+-- it derives, without the 'Node' constructors having to change.+type Annotations = Map Text Value++noAnnotations :: Annotations+noAnnotations = Map.empty++-- | Three constructors, with enough expressivity inside them to carry+-- scalars losslessly -- see @../specs/decisions.md@ #5.+--+-- 'NText' holds a 'Value', not a 'Text': @.p($ctx.count)@ with @count = 3@+-- keeps the number @3@ rather than stringifying it. Rendering a scalar to+-- characters is a host decision, so the interchange format declines to make+-- it.+--+-- 'NElement' holds a @value@ slot alongside its children, for targets that+-- attach a body value to a tagged node (a YAML\/HCL scalar leaf, a config+-- value); it is 'Null' unless a template sets one. Its attributes are an+-- ordered list rather than a map: an element may carry any number of+-- attributes /and/ any number of actions, and source order is preserved.+--+-- 'NFragment' is a real node here -- an ordered sibling sequence with no+-- wrapper element. A host may flatten fragments when folding; evaluation+-- does not.+data Node+  = NText Value Annotations+  | NElement Text [NodeAttribute] Value [Node] Annotations+  | NFragment [Node] Annotations+  deriving stock (Eq, Show)++-- | Both attribute-position constructs, sharing one list. An action's+-- @event@ and @key@ are plain 'Text' because both are static in the source+-- AST (see "Tramaj.Ast"); only the payload is computed.+data NodeAttribute+  = NAttr Text Value+  | NAction Text Text Value+  deriving stock (Eq, Show)++-- Serialization -----------------------------------------------------------++-- | Encodes to the normative representation. Every field is always emitted,+-- including an empty @annotations@ and a @null@ element @value@ -- see+-- @../specs/node-json.md@, "Decoding": on the wire a missing field is a bug,+-- not a default.+nodeToJson :: Node -> Value+nodeToJson (NText v anns) =+  object ["type" .= ("text" :: Text), "value" .= v, "annotations" .= annotationsToJson anns]+nodeToJson (NElement tag attrs val children anns) =+  object+    [ "type" .= ("element" :: Text)+    , "tag" .= tag+    , "attributes" .= V.fromList (map nodeAttributeToJson attrs)+    , "value" .= val+    , "children" .= V.fromList (map nodeToJson children)+    , "annotations" .= annotationsToJson anns+    ]+nodeToJson (NFragment children anns) =+  object+    [ "type" .= ("fragment" :: Text)+    , "children" .= V.fromList (map nodeToJson children)+    , "annotations" .= annotationsToJson anns+    ]++nodeAttributeToJson :: NodeAttribute -> Value+nodeAttributeToJson (NAttr name val) =+  object ["kind" .= ("attribute" :: Text), "name" .= name, "value" .= val]+nodeAttributeToJson (NAction event key payload) =+  object ["kind" .= ("action" :: Text), "event" .= event, "key" .= key, "payload" .= payload]++annotationsToJson :: Annotations -> Value+annotationsToJson = Object . KeyMap.fromList . map (\(k, v) -> (Key.fromText k, v)) . Map.toList++-- | Decodes the normative representation, strictly: a missing or+-- ill-typed field is an error rather than a silently-defaulted value, so+-- @nodeFromJson . nodeToJson@ round-trips and a malformed document is+-- reported where it is read rather than where it later misbehaves. The+-- 'Left' carries a human-readable path-ish description of what was wrong.+nodeFromJson :: Value -> Either String Node+nodeFromJson (Object obj) = do+  ty <- reqString "node" "type" obj+  case ty of+    "text" -> do+      v <- req "text node" "value" obj+      anns <- reqAnnotations obj+      pure (NText v anns)+    "element" -> do+      tag <- reqString "element node" "tag" obj+      attrs <- reqArray "element node" "attributes" obj >>= traverse nodeAttributeFromJson+      val <- req "element node" "value" obj+      children <- reqArray "element node" "children" obj >>= traverse nodeFromJson+      anns <- reqAnnotations obj+      pure (NElement tag attrs val children anns)+    "fragment" -> do+      children <- reqArray "fragment node" "children" obj >>= traverse nodeFromJson+      anns <- reqAnnotations obj+      pure (NFragment children anns)+    other -> Left ("unknown node type: " <> show other)+nodeFromJson _ = Left "expected a JSON object for a node"++nodeAttributeFromJson :: Value -> Either String NodeAttribute+nodeAttributeFromJson (Object obj) = do+  kind <- reqString "node attribute" "kind" obj+  case kind of+    "attribute" -> NAttr <$> reqString "attribute" "name" obj <*> req "attribute" "value" obj+    "action" ->+      NAction+        <$> reqString "action" "event" obj+        <*> reqString "action" "key" obj+        <*> req "action" "payload" obj+    other -> Left ("unknown node attribute kind: " <> show other)+nodeAttributeFromJson _ = Left "expected a JSON object for a node attribute"++req :: String -> Text -> KeyMap.KeyMap Value -> Either String Value+req what field obj = case KeyMap.lookup (Key.fromText field) obj of+  Nothing -> Left (what <> ": missing required field " <> show field)+  Just v -> Right v++reqString :: String -> Text -> KeyMap.KeyMap Value -> Either String Text+reqString what field obj =+  req what field obj >>= \case+    String s -> Right s+    _ -> Left (what <> ": field " <> show field <> " must be a string")++reqArray :: String -> Text -> KeyMap.KeyMap Value -> Either String [Value]+reqArray what field obj =+  req what field obj >>= \case+    Array arr -> Right (V.toList arr)+    _ -> Left (what <> ": field " <> show field <> " must be an array")++reqAnnotations :: KeyMap.KeyMap Value -> Either String Annotations+reqAnnotations obj =+  req "node" "annotations" obj >>= \case+    Object anns -> Right (Map.fromList (map (\(k, v) -> (Key.toText k, v)) (KeyMap.toList anns)))+    _ -> Left "node: field \"annotations\" must be an object"++-- Transformation -----------------------------------------------------------++-- | Rewrites every action reachable in a tree, leaving everything else --+-- tags, ordinary attributes, element value slots, child order, and every+-- annotation map -- untouched. Polymorphic in the applicative so a caller+-- that only fails ('Either') and one that also accumulates something+-- alongside its result (v3-symbols constraint emission) can share this one+-- traversal.+mapActions :: (Applicative f) => (Text -> Text -> Value -> f NodeAttribute) -> Node -> f Node+mapActions _ n@(NText _ _) = pure n+mapActions f (NElement tag attrs val children anns) =+  NElement tag <$> traverse step attrs <*> pure val <*> traverse (mapActions f) children <*> pure anns+  where+    step a@(NAttr _ _) = pure a+    step (NAction event key payload) = f event key payload+mapActions f (NFragment children anns) =+  NFragment <$> traverse (mapActions f) children <*> pure anns

@@ -0,0 +1,974 @@+-- | Surface syntax to core AST. Everything the surface offers beyond+-- "Tramaj.Ast"'s constructors is desugared here rather than represented:+--+-- * @\@name=expr@ binding lines become nested 'Let's;+-- * string interpolation becomes 'Concat' over the @str@ builtin;+-- * @branch(fallback, p1, v1, ...)@ becomes nested 'Branch';+-- * object shorthand @{foo}@ becomes @{"foo": $foo}@;+-- * escape sequences are resolved into the 'StringLit' they denote.+--+-- The grammar keeps three leader characters from v1: @.@ introduces a+-- document, @$@ reads a binding, @\@@ defines one. What changed is that+-- there is now a single expression grammar -- v1's separate template-phase+-- productions (@node@, @nodeArg@, @childArg@, @templateSpecialForm@,+-- @pathOrCallChild@) are gone, because documents are expressions.+--+-- A fourth character is lexical rather than grammatical: @--@ begins a+-- comment that runs to the end of the line. It is discarded by 'skipSpaces'+-- along with whitespace, so it never reaches the AST and there is nothing to+-- desugar.+--+-- Two conventions are load-bearing and carried over deliberately:+--+-- * A special form's 'try' covers /name recognition only/. Once @import@ or+--   @map@ has matched, its shape is parsed without backtracking, so a+--   malformed one is a hard parse error instead of silently falling through+--   to a meaningless 'Call' that would only fail much later at eval time.+-- * A field-access suffix is parsed with no whitespace skipped before it, so+--   @f().rendered@ is a field access while @f()@ followed by a newline and+--   @.div(...)@ is two separate things.+module Tramaj.Parser+  ( parseProgram+  , parseExpr+  ) where++import Data.Char (chr, isAlphaNum, isDigit, isHexDigit, isLetter)+import Data.List (nub)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void (Void)+import Numeric (readHex)+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import Tramaj.Ast++type P = Parsec Void Text++-- | One argument of an element, before the arguments are bucketed into+-- attributes, the value slot, and children -- and before the+-- attributes-before-children rule is checked, which needs to see them in+-- source order.+data ElementArg+  = EArgAttr Attribute+  | EArgValue Expr+  | EArgChild Expr++-- | One piece of a double-quoted string, before 'desugarString' folds the+-- pieces into core constructors. Not part of the AST: core.md is explicit+-- that interpolation needs no node of its own.+data StringPart+  = SLit Text+  | SInterp Expr++-- Lexing --------------------------------------------------------------++-- | Whitespace and comments -- everything between two tokens that carries no+-- meaning. Run after every token by 'lexeme', and once before the first one,+-- so a comment is legal anywhere a space is.+--+-- A comment is @--@ to the end of the line. Single-line only: there is no+-- block form, so there is no nesting rule to get wrong and no way to leave one+-- unterminated. @--@ inside a string literal is ordinary text, because string+-- bodies are read character by character and never come through here.+--+-- This is also why 'rawIdent' refuses a trailing hyphen: it is what keeps+-- @$x-- note@ from lexing as a name @x--@ instead of @$x@ and a comment.+skipSpaces :: P ()+skipSpaces = L.space space1 (L.skipLineComment "--") empty++lexeme :: P a -> P a+lexeme p = p <* skipSpaces++symbol :: Text -> P Text+symbol s = lexeme (string s)++-- | An identifier with no trailing whitespace consumed -- used where the+-- following character is significant: inside dotted paths and after an+-- element's @.@. Internal hyphens are allowed (kebab-case), so @$my-var@ and+-- @.my-tag@ are one token each.+--+-- /Internal/ is enforced, not merely documented: a hyphen is part of the name+-- only when another name character follows it. Without that, a name would+-- swallow the @--@ of a comment written directly after it, and @$x-- note@+-- would read as the name @x--@.+rawIdent :: P Text+rawIdent = do+  c0 <- satisfy isLetter+  cs <- many identRest+  pure (T.pack (c0 : cs))+  where+    identRest :: P Char+    identRest = identChar <|> try (char '-' <* lookAhead identChar)++    identChar :: P Char+    identChar = satisfy (\c -> isAlphaNum c || c == '_')++identifier :: P Text+identifier = lexeme rawIdent++pathTail :: P (Text, [Text])+pathTail = do+  root <- rawIdent+  rest <- many (char '.' *> rawIdent)+  pure (root, rest)++-- | Zero or more @.field@ segments directly after a closing @)@. Deliberately+-- runs before any whitespace is skipped -- see the module header.+fieldAccessSuffix :: P [Text]+fieldAccessSuffix = many (try (char '.' *> rawIdent))++applyFieldAccess :: Expr -> [Text] -> Expr+applyFieldAccess base [] = base+applyFieldAccess base segs = FieldAccess base segs++-- | A double-quoted string with no interpolation: every statically-required+-- position uses this, so what the source says is what the analysis sees.+-- Import names, action events and keys, adaptation prefixes and object keys+-- are all parsed with it.+--+-- A backtick here is an error rather than a literal backtick. Someone writing+-- @import("lib-`$x`")@ means interpolation, and silently handing them a+-- library named @lib-`$x`@ would answer a question they did not ask -- the+-- whole point of the position being static is that it cannot be computed.+staticString :: P Text+staticString = lexeme $ do+  _ <- char '"'+  s <- takeWhileP Nothing (\c -> c /= '"' && c /= '`')+  _ <- char '"' <|> interpolationRefused+  pure s+  where+    interpolationRefused =+      fail "this position must be a literal string, so it cannot contain an interpolation"++-- Strings ---------------------------------------------------------------++-- | A string literal: escape sequences plus backtick interpolation of an+-- arbitrary expression.+stringLit :: P Expr+stringLit = lexeme $ do+  _ <- char '"'+  parts <- many stringPart+  _ <- char '"'+  pure (desugarString parts)+  where+    stringPart :: P StringPart+    stringPart = interpPart <|> (SLit <$> litChunk)++    interpPart :: P StringPart+    interpPart = SInterp <$> (char '`' *> expr <* char '`')++    -- | A run of ordinary characters, with escape sequences resolved as they+    -- are read. Stops at a closing quote or an interpolation's backtick;+    -- either can still be written escaped.+    litChunk :: P Text+    litChunk = T.concat <$> some (escapeSeq <|> plainRun)++    plainRun :: P Text+    plainRun = takeWhile1P Nothing (\c -> c /= '"' && c /= '`' && c /= '\\')++escapeSeq :: P Text+escapeSeq = char '\\' *> (unicodeEscape <|> simpleEscape)+  where+    simpleEscape :: P Text+    simpleEscape = do+      c <- anySingle+      case c of+        'n' -> pure "\n"+        't' -> pure "\t"+        'r' -> pure "\r"+        '\\' -> pure "\\"+        '"' -> pure "\""+        '`' -> pure "`"+        '0' -> pure "\0"+        _ -> fail ("unknown escape sequence: \\" <> [c])++    -- | @\\u{1F600}@ -- braced so it is not limited to four hex digits and+    -- does not need surrogate pairs.+    unicodeEscape :: P Text+    unicodeEscape = do+      _ <- char 'u'+      _ <- char '{'+      digits <- takeWhile1P (Just "hex digit") isHexDigit+      _ <- char '}'+      case readHex (T.unpack digits) of+        [(n, "")] | n <= 0x10FFFF -> pure (T.singleton (chr n))+        _ -> fail ("invalid unicode escape: \\u{" <> T.unpack digits <> "}")++-- | Folds string pieces into core constructors. A string with no+-- interpolation is a plain 'StringLit'; otherwise each interpolated+-- expression is rendered through the @str@ builtin and the pieces are joined+-- with 'Concat', which is exactly what @"a `$x` b"@ means.+desugarString :: [StringPart] -> Expr+desugarString parts = case map partExpr (coalesce parts) of+  [] -> StringLit ""+  (e : es) -> foldl Concat e es+  where+    partExpr (SLit t) = StringLit t+    partExpr (SInterp e) = Call (Path "str" []) [e]++    -- | Adjacent literal chunks (an escape sequence splits one in two) are+    -- merged, so an escape does not leave a stray 'Concat' in the AST.+    coalesce (SLit a : SLit b : rest) = coalesce (SLit (a <> b) : rest)+    coalesce (p : rest) = p : coalesce rest+    coalesce [] = []++-- Literals ---------------------------------------------------------------++-- | @["-"] digits ["." digits] [("e"|"E") ["+"|"-"] digits]@, where a @_@+-- may sit between two digits (reference.md §5, /Number literals/). The+-- fraction and exponent are taken only when complete, so a stray @.@, @e@+-- or @_@ is left for the caller to reject. The underscores are dropped and+-- the exponent's sign normalized before the text reaches 'reads'; an+-- overflow to infinity is refused and a zero is normalized so @-0@ never+-- escapes.+numberLit :: P Expr+numberLit = lexeme $ try $ do+  sign <- optional (char '-')+  intPart <- digits+  fracPart <- optional (try (char '.' *> digits))+  expPart <- optional $ try $ do+    _ <- char 'e' <|> char 'E'+    expSign <- optional (char '+' <|> char '-')+    expDigits <- digits+    pure (if expSign == Just '-' then "-" <> expDigits else expDigits)+  let fullStr =+        maybe "" (const "-") sign+          <> intPart+          <> maybe "" ("." <>) fracPart+          <> maybe "" ("e" <>) expPart+  case reads (T.unpack fullStr) :: [(Double, String)] of+    [(n, "")]+      | isInfinite n -> fail ("number literal out of range: " <> T.unpack fullStr)+      | n == 0 -> pure (NumberLit 0)+      | otherwise -> pure (NumberLit n)+    _ -> fail ("invalid number literal: " <> T.unpack fullStr)+  where+    digits = do+      first <- takeWhile1P (Just "digit") isDigit+      rest <- many (try (char '_' *> takeWhile1P (Just "digit") isDigit))+      pure (T.concat (first : rest))++-- | @true@\/@false@\/@null@ matched as whole identifiers, so a longer name+-- merely starting with one (@truest@, @nullable@) is not chopped into a+-- literal plus leftovers.+keywordLit :: P Expr+keywordLit = try $ do+  name <- identifier+  case name of+    "true" -> pure (BoolLit True)+    "false" -> pure (BoolLit False)+    "null" -> pure NullLit+    _ -> fail "not a literal keyword"++arrayLit :: P Expr+arrayLit = lexeme $ do+  _ <- symbol "["+  elems <- sepEndBy expr (symbol ",")+  _ <- symbol "]"+  pure (ArrayLit elems)++-- | Object keys may be quoted or bare, and a bare key on its own is shorthand+-- for reading the binding of the same name: @{foo, bar: $baz}@.+objectLit :: P Expr+objectLit = lexeme $ do+  _ <- symbol "{"+  entries <- sepEndBy objEntry (symbol ",")+  _ <- symbol "}"+  pure (ObjectLit entries)+  where+    objEntry :: P (Text, Expr)+    objEntry = try explicitEntry <|> shorthandEntry++    explicitEntry :: P (Text, Expr)+    explicitEntry = do+      k <- objectKey+      _ <- reservedKeyRefused k+      _ <- symbol ":"+      v <- expr+      pure (k, v)++    shorthandEntry :: P (Text, Expr)+    shorthandEntry = do+      k <- identifier+      pure (k, Path k [])++objectKey :: P Text+objectKey = staticString <|> identifier++-- | @"$sym"@ and @"$type"@ are reserved across the value domain (v3-symbols+-- \S5.3, v4-types \S0): the tag a symbolic or typed envelope uses to mark a+-- value that is not an ordinary object. An object literal spelling either as+-- a key is a parse error in every profile, not just the symbolic one, so a+-- program's legality never depends on which profile runs it.+reservedKeyRefused :: Text -> P ()+reservedKeyRefused k+  | k `elem` (["$sym", "$type"] :: [Text]) =+      fail ("\"" <> T.unpack k <> "\" is a reserved key and cannot be used as an object key")+  | otherwise = pure ()++-- Expressions ------------------------------------------------------------++pathExpr :: P Expr+pathExpr = lexeme $ do+  _ <- char '$'+  (root, fields) <- pathTail+  pure (Path root fields)++-- | @?(key)@ (v3-symbols \S1.2): allocates a symbol. The site is a placeholder+-- here -- 'Tramaj.Ast.numberAllocs' assigns the real one once the whole+-- program has been parsed, so it does not depend on this parser's own+-- traversal order. A projection following it, as in @?(key).field@, is an+-- ordinary field-access suffix, the same mechanism a call result uses.+allocExpr :: P Expr+allocExpr = try $ do+  _ <- char '?'+  _ <- symbol "("+  keyExpr <- expr+  _ <- char ')'+  segs <- fieldAccessSuffix+  skipSpaces+  pure (applyFieldAccess (Alloc 0 keyExpr) segs)++-- | @?ctx.a.b@ (\S1.3): the path MUST be rooted at @ctx@ -- unlike an+-- ordinary read, an unsupplied demand allocates at the root rather than+-- failing, so the language needs to tell the two apart before evaluating+-- anything.+demandExpr :: P Expr+demandExpr = lexeme $ try $ do+  _ <- char '?'+  root <- rawIdent+  if root == "ctx"+    then Demand <$> many (char '.' *> rawIdent)+    else fail "a demand must be rooted at ctx, as in ?ctx.path"++-- | @name(args)@ or @$name(args)@ -- the two spellings mean the same thing.+-- The callee may be a dotted path, so a function reached through an import's+-- values (@$lib.vals.fn(1)@) or an import being given more parameters+-- (@$deployment({...})@) is callable directly.+call :: P Expr+call = try $ do+  _ <- optional (char '$')+  (root, fields) <- pathTail+  _ <- symbol "("+  args <- sepEndBy expr (symbol ",")+  _ <- char ')'+  segs <- fieldAccessSuffix+  skipSpaces+  pure (applyFieldAccess (Call (Path root fields) args) segs)++lambdaExpr :: P Expr+lambdaExpr = try $ do+  _ <- symbol "("+  params <- sepEndBy pattern (symbol ",")+  _ <- symbol ")"+  _ <- symbol "=>"+  lowerLambda params <$> expr++-- Binding patterns (decisions \S17) -------------------------------------------++-- | A binding pattern: a name, or an object pattern @{a, b: c, d: {e}}@.+-- Object patterns only; defaults (@{a = 1}@), rest (@{...r}@) and array+-- patterns are deliberately not in the grammar, so they are parse errors.+data Pattern+  = PName Text+  | PObject [(Text, Pattern)]++pattern :: P Pattern+pattern = (PName <$> identifier) <|> objectPattern++objectPattern :: P Pattern+objectPattern = do+  _ <- symbol "{"+  fields <- sepEndBy1 patternField (symbol ",")+  _ <- symbol "}"+  let pat = PObject fields+      names = patternNames pat+  if length (nub names) /= length names+    then fail "duplicate name in a binding pattern"+    else pure pat++-- | @name@ reads that field into a binding of the same name; @name: p@ reads+-- it and binds or destructures it as @p@.+patternField :: P (Text, Pattern)+patternField = do+  k <- identifier+  sub <- optional (symbol ":" *> pattern)+  pure (k, fromMaybe (PName k) sub)++patternNames :: Pattern -> [Text]+patternNames (PName n) = [n]+patternNames (PObject fields) = concatMap (patternNames . snd) fields++-- | Lowers @pattern = source@ to plain bindings, in written order. A source+-- that is a path is read directly (@$ctx.item.a@), so errors and static+-- analyses see the reads a hand-written program would make; anything else is+-- bound once to the hidden name @#src@ first. Hidden names start with @#@,+-- which no surface name can, and are dropped from a symbol's @"binding"@ and+-- from a library's @.vals@ ('isHiddenName').+bindPattern :: Pattern -> Expr -> [Stmt]+bindPattern (PName n) source = [SLet n source]+bindPattern (PObject fields) source = case source of+  Path _ _ -> readFields source+  _ -> SLet "#src" source : readFields (Path "#src" [])+  where+    readFields src = concatMap (\(k, p) -> bindPattern p (readField src k)) fields++    readField (Path root segs) k = Path root (segs ++ [k])+    readField other k = FieldAccess other [k]++-- | A pattern parameter becomes a hidden parameter @#argN@; the body is+-- wrapped in the bindings that read the pattern's names out of it.+lowerLambda :: [Pattern] -> Expr -> Expr+lowerLambda params body =+  Lambda (zipWith paramName [0 :: Int ..] params) (stmts (concat (zipWith unpack [0 :: Int ..] params)) body)+  where+    paramName _ (PName n) = n+    paramName i (PObject _) = "#arg" <> T.pack (show i)++    unpack _ (PName _) = []+    unpack i p@(PObject _) = bindPattern p (Path ("#arg" <> T.pack (show i)) [])++-- | Grouping, for readability where 'Concat' chains get long. Not a semantic+-- construct: the parse tree it produces is the same as the inner expression's.+parenExpr :: P Expr+parenExpr = try $ do+  _ <- symbol "("+  e <- expr+  _ <- symbol ")"+  pure e++-- | The forms whose evaluation the language defines itself, rather than+-- leaving to a builtin: the array primitives (whose function argument needs a+-- fresh binding per element), 'Branch' (which must not evaluate the arm it+-- does not select), imports, and action adaptation.+--+-- The 'try' covers name recognition only -- see the module header.+specialForm :: P Expr+specialForm = do+  name <- try $ do+    _ <- optional (char '$')+    n <- identifier+    if n `elem` (["map", "filter", "scan", "fold", "branch", "import", "adapt-actions", "constraint"] :: [Text])+      then pure n+      else fail "not a special form"+  base <- case name of+    "map" -> binaryShape Map+    "filter" -> binaryShape Filter+    "scan" -> ternaryShape Scan+    "fold" -> ternaryShape Fold+    "branch" -> branchShape+    "import" -> importShape+    "adapt-actions" -> adaptActionsShape+    "constraint" -> constraintShape+    _ -> fail "unreachable: name already checked against the recognized special-form set"+  segs <- fieldAccessSuffix+  skipSpaces+  pure (applyFieldAccess base segs)+  where+    binaryShape :: (Expr -> Expr -> Expr) -> P Expr+    binaryShape ctor = do+      _ <- symbol "("+      a <- expr+      _ <- symbol ","+      b <- expr+      _ <- char ')'+      pure (ctor a b)++    ternaryShape :: (Expr -> Expr -> Expr -> Expr) -> P Expr+    ternaryShape ctor = do+      _ <- symbol "("+      a <- expr+      _ <- symbol ","+      b <- expr+      _ <- symbol ","+      c <- expr+      _ <- char ')'+      pure (ctor a b c)++    -- | @branch(fallback, p1, v1, p2, v2, ...)@ reads "if p1 then v1, else if+    -- p2 then v2, ..., else fallback" and lowers to nested 'Branch', so the+    -- laziness is the core constructor's rather than a rule of its own.+    branchShape :: P Expr+    branchShape = do+      _ <- symbol "("+      fallback <- expr+      arms <- many (try (symbol "," *> arm))+      _ <- optional (symbol ",")+      _ <- char ')'+      pure (foldr (\(p, v) acc -> Branch p v acc) fallback arms)++    arm :: P (Expr, Expr)+    arm = do+      p <- expr+      _ <- symbol ","+      v <- expr+      pure (p, v)++    -- | @constraint(name, arg1, arg2, ...)@ (v3-symbols \S2.1): a static+    -- string name, like an action's event and key, followed by any number of+    -- ordinary expressions -- zero included, since the language fixes no+    -- signature for any name.+    constraintShape :: P Expr+    constraintShape = do+      _ <- symbol "("+      name <- staticString+      args <- many (try (symbol "," *> expr))+      _ <- optional (symbol ",")+      _ <- char ')'+      pure (Constrain name args)++    -- | @import("name", {param: expr, other: ctx(path)})@. The name is a+    -- static literal, and the parameters are a dedicated production rather+    -- than an ordinary object expression, because @ctx(...)@ means something+    -- only here.+    importShape :: P Expr+    importShape = do+      _ <- symbol "("+      name <- staticString+      _ <- symbol ","+      params <- importParams+      _ <- char ')'+      pure (Import name params)++    importParams :: P [(Text, ParamValue)]+    importParams = do+      _ <- symbol "{"+      entries <- sepEndBy paramEntry (symbol ",")+      _ <- symbol "}"+      pure entries++    paramEntry :: P (Text, ParamValue)+    paramEntry = try explicitParam <|> shorthandParam++    explicitParam :: P (Text, ParamValue)+    explicitParam = do+      k <- objectKey+      _ <- symbol ":"+      v <- paramValue+      pure (k, v)++    shorthandParam :: P (Text, ParamValue)+    shorthandParam = do+      k <- identifier+      pure (k, PExpr (Path k []))++    -- | @ctx(spec.replicas)@ reads this program's own @$ctx.spec.replicas@,+    -- and means exactly that. The separate form exists so the path lands in a+    -- static position the analyses can read; see "Tramaj.Ast"'s 'ParamValue'.+    paramValue :: P ParamValue+    paramValue = (PType <$> markedTypeExpr) <|> fromContext <|> (PExpr <$> expr)++    fromContext :: P ParamValue+    fromContext = do+      _ <- try $ do+        n <- identifier+        _ <- lookAhead (char '(')+        if n == ("ctx" :: Text) then pure n else fail "not a ctx(...) parameter"+      _ <- symbol "("+      (root, fields) <- pathTail+      skipSpaces+      _ <- char ')'+      skipSpaces+      pure (PFromContext (root : fields))++    -- | @adapt-actions(node, prefix("ns:"))@, optionally with a closure for+    -- the event type and payload.+    adaptActionsShape :: P Expr+    adaptActionsShape = do+      _ <- symbol "("+      target <- expr+      _ <- symbol ","+      adaptation <- adaptationShape+      fn <- optional (try (symbol "," *> expr))+      _ <- optional (symbol ",")+      _ <- char ')'+      pure (AdaptActions target adaptation fn)++    -- | Two forms only, never an arbitrary rewriting function: this is what+    -- keeps the set of action keys a program can emit enumerable without+    -- evaluating it.+    adaptationShape :: P ActionAdaptation+    adaptationShape = do+      name <- identifier+      case name of+        "identity" -> pure Identity+        "prefix" -> do+          _ <- symbol "("+          p <- staticString+          _ <- char ')'+          skipSpaces+          pure (Prefix p)+        _ -> fail "an action adaptation must be identity or prefix(\"...\")"++-- Types ---------------------------------------------------------------------++-- | The five value-domain shapes v4-types \S1 reserves as type primitives.+-- Fixed and closed, so recognized here rather than left for a later+-- resolution pass to classify.+primNames :: [Text]+primNames = ["string", "number", "bool", "null", "document"]++-- | A type expression (v4-types \S1), in the position a full 'TypeExpr' may+-- appear: a declaration's right-hand side, a record field's type, an array's+-- element type. 'typeUnion' and 'typePrimOrRef' are included here but+-- deliberately excluded from 'typeExprPayload', which is what a union arm's+-- own payload parses with -- see that function for why.+typeExpr :: P TypeExpr+typeExpr = typeVar <|> typeUnion <|> typeArray <|> typeRecord <|> typePrimOrRef++-- | Everything a union arm's payload may be. Deliberately narrower than+-- 'typeExpr': a nested union has no bracketing in the surface grammar, and a+-- bare name (a 'TPrim' or 'TName') is excluded because nothing marks where a+-- nullary arm ends -- @| Dev | Staging@ must parse as two nullary arms, not+-- @Dev@ with a payload named @Staging@, and the same trap would swallow a+-- following statement's root expression whenever it starts with a bare+-- identifier (@true@, or a special form written without its leading @$@).+-- Every constructor kept here starts with a token -- @%@, @[@, @{@ -- that+-- cannot otherwise begin whatever follows a union declaration, so no such+-- ambiguity exists for them.+typeExprPayload :: P TypeExpr+typeExprPayload = typeVar <|> typeArray <|> typeRecord++-- | @%ctx.a.b@ (v4-types \S1): a type hole. The path MUST be rooted at @ctx@,+-- mirroring 'demandExpr' on the value side.+typeVar :: P TypeExpr+typeVar = lexeme $ try $ do+  _ <- char '%'+  root <- rawIdent+  if root == "ctx"+    then TVar <$> many (char '.' *> rawIdent)+    else fail "a type hole must be rooted at ctx, as in %ctx.path"++-- | A @%@-marked type argument, in the two positions v4-types \S2 and \S5+-- both use it: an import parameter's value, and a @!type-constraint@+-- argument. Unlike 'typeVar', the leading @%@ here does not require what+-- follows to be @ctx@ -- @%Json@ (\S2's supply) and @%ctx.payload@ (\S6's+-- forward) are both legal, told apart only after the @%@ itself is seen, so+-- this cannot simply be @char \'%\' *> typeExpr@: that would need a second+-- @%@ before the @ctx@ case. 'typeUnion'\/'typeArray'\/'typeRecord'\/+-- 'typePrimOrRef' need no such adjustment, since none of them themselves+-- start with @%@.+markedTypeExpr :: P TypeExpr+markedTypeExpr = try $ do+  _ <- char '%'+  ctxForward <|> typeUnion <|> typeArray <|> typeRecord <|> typePrimOrRef+  where+    ctxForward :: P TypeExpr+    ctxForward = lexeme $ try $ do+      root <- rawIdent+      if root == ("ctx" :: Text)+        then TVar <$> many (char '.' *> rawIdent)+        else fail "a %-marked value must be ctx.path or a type expression"++typeArray :: P TypeExpr+typeArray = do+  _ <- symbol "["+  t <- typeExpr+  _ <- symbol "]"+  pure (TArray t)++typeRecord :: P TypeExpr+typeRecord = do+  _ <- symbol "{"+  fields <- sepEndBy typeField (symbol ",")+  _ <- symbol "}"+  pure (TRecord fields)+  where+    -- | Unlike an ordinary object literal's 'objectKey', a field name here is+    -- always a bare 'identifier', never a quoted string (v4-types \S1.1's+    -- examples never show one either). This is what keeps a canonical id+    -- (v4-types \S3, "Tramaj.Types") injective: the id grammar uses @:@,+    -- @,@, @[@, @]@ and @|@ as its own delimiters, and an identifier can+    -- never contain any of them, so inserting a field name raw can never be+    -- confused with the surrounding structure. A quoted key could.+    typeField :: P (Text, TypeExpr)+    typeField = do+      k <- identifier+      _ <- symbol ":"+      t <- typeExpr+      pure (k, t)++-- | @| A T | B U | C@ (v4-types \S1.1): one or more arms, each a name with an+-- optional payload -- a nullary arm is an enum case, not a payload-carrying+-- one with an empty payload.+typeUnion :: P TypeExpr+typeUnion = TUnion <$> some (symbol "|" *> unionArm)+  where+    unionArm :: P (Text, Maybe TypeExpr)+    unionArm = do+      name <- identifier+      payload <- optional typeExprPayload+      pure (name, payload)++-- | A bare name (a primitive keyword or a declaration reference) or a+-- library-qualified one, @$lib.types.Name@ (v4-types \S1.1's @\@m :+-- $msg.types.Envelope@). Which of 'TName' and 'TLibRef' applies is a purely+-- syntactic distinction here; resolving either to a primitive, a+-- declaration, or 'UnresolvedType' is a later pass's job (v4-types \S9, not+-- yet implemented).+typePrimOrRef :: P TypeExpr+typePrimOrRef = libRef <|> nameOrPrim+  where+    libRef :: P TypeExpr+    libRef = lexeme $ try $ do+      _ <- char '$'+      libName <- rawIdent+      _ <- char '.'+      _ <- string "types"+      _ <- char '.'+      typeName <- rawIdent+      pure (TLibRef libName typeName)++    nameOrPrim :: P TypeExpr+    nameOrPrim = do+      name <- identifier+      pure (if name `elem` primNames then TPrim name else TName name)++-- | One argument to @!type-constraint@ (v4-types \S5): a @%@-marked type+-- expression, or a literal scalar -- reusing the same primitive literal+-- parsers 'numberLit'\/'keywordLit' use, unwrapped to the scalar the+-- argument actually carries, since it is never wrapped as an evaluable+-- 'Expr' here. A string scalar is 'staticString', not 'stringLit': like a+-- constraint's own name, this position is never computed.+typeConstraintArg :: P TypeConstraintArg+typeConstraintArg = (TCType <$> markedTypeExpr) <|> scalarArg+  where+    scalarArg :: P TypeConstraintArg+    scalarArg =+      (TCScalarStr <$> staticString)+        <|> (asScalar <$> numberLit)+        <|> (asScalar <$> keywordLit)++    asScalar :: Expr -> TypeConstraintArg+    asScalar (NumberLit n) = TCScalarNum n+    asScalar (BoolLit b) = TCScalarBool b+    asScalar NullLit = TCScalarNull+    asScalar (StringLit s) = TCScalarStr s+    asScalar _ = TCScalarNull -- unreachable: 'numberLit'/'keywordLit' only ever produce the cases above++-- | @!type-constraint(name, args...)@ (v4-types \S5, roadmap Phase 12): tried+-- before the general @!expr@ 'emission', since both share the @!@ leader and+-- @type-constraint(...)@ would otherwise parse as an ordinary call to an+-- unbound name.+typeEmission :: P Stmt+typeEmission = try $ do+  _ <- char '!'+  kw <- identifier+  if kw /= ("type-constraint" :: Text) then fail "not a !type-constraint" else pure ()+  _ <- symbol "("+  name <- staticString+  args <- many (try (symbol "," *> typeConstraintArg))+  _ <- optional (symbol ",")+  _ <- char ')'+  skipSpaces+  pure (STypeEmit name args)++-- | @type Name = TypeExpr@ (v4-types \S1.1): the fifth statement leader.+-- Unlike @\@@\/@!@\/@.\@$@ it is a whole keyword rather than a single+-- character, so it is recognized by parsing a full identifier and checking+-- it -- the same device 'keywordLit' uses -- which is what keeps @typeface =+-- ...@ from being chopped into the keyword @type@ plus leftovers.+typeDeclStmt :: P Stmt+typeDeclStmt = try $ do+  kw <- identifier+  if kw /= "type" then fail "not a type declaration" else pure ()+  name <- identifier+  _ <- symbol "="+  STypeDecl name <$> typeExpr++-- Documents ---------------------------------------------------------------++-- | @.tag(...)@ is an element; @.(...)@ is a fragment -- a tagless element,+-- introducing siblings with no wrapper.+documentExpr :: P Expr+documentExpr = try $ do+  _ <- char '.'+  choice [fragmentShape, elementShape]+  where+    fragmentShape :: P Expr+    fragmentShape = do+      _ <- symbol "("+      children <- sepEndBy expr (symbol ",")+      _ <- symbol ")"+      pure (Fragment children)++    elementShape :: P Expr+    elementShape = do+      tag <- rawIdent+      skipSpaces+      _ <- symbol "("+      args <- sepEndBy elementArg (symbol ",")+      _ <- symbol ")"+      buildElement tag args++-- | Buckets an element's arguments and enforces the one ordering rule:+-- everything in attribute position comes before any child.+buildElement :: Text -> [ElementArg] -> P Expr+buildElement tag args = do+  ensureAttrsBeforeChildren+  val <- singleValueSlot+  pure (Element tag [a | EArgAttr a <- args] val [c | EArgChild c <- args])+  where+    ensureAttrsBeforeChildren :: P ()+    ensureAttrsBeforeChildren+      | fst (foldl step (True, False) args) = pure ()+      | otherwise = fail "attributes, action(...) and value(...) must all come before an element's children"+      where+        step (ok, seenChild) arg = case arg of+          EArgChild _ -> (ok, True)+          _ -> (ok && not seenChild, seenChild)++    singleValueSlot :: P Expr+    singleValueSlot = case [v | EArgValue v <- args] of+      [] -> pure NullLit+      [v] -> pure v+      _ -> fail "an element can have at most one value(...)"++elementArg :: P ElementArg+elementArg =+  attributePositionArg+    <|> (EArgAttr <$> try namedArg)+    <|> (EArgChild <$> expr)++-- | @action(...)@ and @value(...)@, the two forms that mean something only in+-- an element's argument list.+--+-- As with 'specialForm', the 'try' covers name recognition only: once+-- @action@ has been seen applied to arguments, a malformed one is a parse+-- error. Letting it backtrack would leave @action("on-click", $computed, {})@+-- parsing happily as a call to an unbound function named @action@, and the+-- static-key restriction would be enforced by nothing at all.+--+-- Recognition needs the following @(@, so @action@ and @value@ remain usable+-- as ordinary attribute names: @value: 1@ is an attribute, @value(1)@ is the+-- value slot.+attributePositionArg :: P ElementArg+attributePositionArg = do+  name <- try $ do+    n <- identifier+    _ <- lookAhead (char '(')+    if n `elem` (["action", "value"] :: [Text])+      then pure n+      else fail "not an action(...) or value(...) form"+  case name of+    "action" -> EArgAttr <$> actionShape+    _ -> EArgValue <$> valueShape++-- | @action("on-click", "save", payloadExpr)@. Both the event and the key are+-- static literals; only the payload is computed. The host still owns the+-- event vocabulary -- what is fixed is the position, not the words allowed in+-- it.+actionShape :: P Attribute+actionShape = do+  _ <- symbol "("+  event <- staticString+  _ <- symbol ","+  key <- staticString+  _ <- symbol ","+  payload <- expr+  _ <- symbol ")"+  pure (ActionAttr event key payload)++-- | @value(expr)@ fills the element's value slot -- see "Tramaj.Node" for+-- what a host does with it.+valueShape :: P Expr+valueShape = do+  _ <- symbol "("+  v <- expr+  _ <- symbol ")"+  pure v++namedArg :: P Attribute+namedArg = do+  name <- objectKey+  _ <- symbol ":"+  Attr name <$> expr++-- Precedence ---------------------------------------------------------------++-- | @a \<\> b@, left-associative and the lowest precedence in the language --+-- the only infix operator there is.+expr :: P Expr+expr = do+  first <- operand+  rest <- many (try (symbol "<>" *> operand))+  pure (foldl Concat first rest)++-- | Alternatives are ordered so that a longer form is tried before a prefix of+-- it: keyword literals before paths and calls, special forms before ordinary+-- calls, lambdas before parenthesized expressions.+operand :: P Expr+operand =+  keywordLit+    <|> lambdaExpr+    <|> parenExpr+    <|> specialForm+    <|> call+    <|> pathExpr+    <|> allocExpr+    <|> demandExpr+    <|> documentExpr+    <|> stringLit+    <|> numberLit+    <|> arrayLit+    <|> objectLit++-- Programs -----------------------------------------------------------------++-- | @\@name=expr@ or @\@name : T = expr@ (v4-types \S7), one per line. @\@@+-- leads a binding definition, mirroring @$@ leading a binding read; the+-- optional @: T@ is what tells 'SLet' and 'SAnnotate' apart.+binding :: P [Stmt]+binding = try $ do+  _ <- char '@'+  pat <- pattern+  case pat of+    -- No annotation on a pattern (decisions \S17): a @:@ here is a parse error.+    PObject _ -> do+      _ <- symbol "="+      bindPattern pat <$> expr+    PName name -> do+      annot <- optional (try (symbol ":" *> typeExpr))+      _ <- symbol "="+      e <- expr+      pure [maybe (SLet name e) (\t -> SAnnotate name t e) annot]++-- | @!expr@ (v3-symbols \S2.2): the fourth statement leader, joining @.@,+-- @$@ and @\@@. A statement position only -- it may not appear inside an+-- expression, so there is no operand form for it.+emission :: P Expr+emission = try $ do+  _ <- char '!'+  expr++-- | One statement of the surface grammar: a binding (plain or annotated), an+-- emission (value or type), or a type declaration, in the order the source+-- wrote them -- what 'Ast.stmts' rebuilds into the core chain. 'typeEmission'+-- is tried ahead of 'emission' since both share the @!@ leader.+statement :: P [Stmt]+statement = binding <|> (pure <$> typeEmission) <|> (pure . SEmit <$> emission) <|> (pure <$> typeDeclStmt)++-- | A program is a sequence of statements and a root expression. Which kind+-- of program it is follows from the root's own form -- a document root is+-- exactly one written as a document -- so there is no mode to declare and no+-- separate entry point to pick.+parseProgram :: Text -> Either (ParseErrorBundle Text Void) Program+parseProgram = runParser program ""+  where+    program :: P Program+    program = do+      skipSpaces+      statements <- many statement+      root <- expr+      skipSpaces+      eof+      let programBody = numberAllocs (stmts (concat statements) root)+      pure $ case root of+        Element {} -> DocumentProgram programBody+        Fragment {} -> DocumentProgram programBody+        _ -> ExpressionProgram programBody++parseExpr :: Text -> Either (ParseErrorBundle Text Void) Expr+parseExpr = runParser (numberAllocs <$> (skipSpaces *> expr <* eof)) ""

@@ -0,0 +1,521 @@+-- | v4-types resolution, normalisation, canonical identity, and the closure+-- and constraint machinery output needs (roadmap-to-v4 Phases 9, 10, 13, 14).+-- Kept as its own module, the way "Tramaj.Analysis" is kept apart from+-- "Tramaj.Eval": this is a static pass over parsed programs, evaluates+-- nothing, and its only dependencies are "Tramaj.Ast" and "Tramaj.Analysis".+--+-- Scope, precisely: v4-types \S9 says resolution and identity are the whole+-- of what a type-aware analysis does before evaluation, and \S3 fixes the+-- one property every implementation must agree on -- two spellings of the+-- same type must produce the *same string*, and two different types must+-- never collide.+--+-- __Type parameters (roadmap Phase 10).__ A 'Ref'\'s @arguments@ (v4-types+-- \S1) come from nowhere in the surface syntax at the reference site --+-- @$msg.types.Envelope@ carries no bracketed application. They come instead+-- from /how @msg@ was imported/ (\S2): 'resolveLibBinding' now returns the+-- import's own params alongside its key and program, and a 'TLibRef'+-- resolves its 'RRef'\'s @arguments@ by intersecting those params'+-- @%@-marked entries with the target library's own 'typeParams' -- the set+-- 'Tramaj.Analysis.typeParams' already computes without resolving anything.+-- Each supplied argument is itself resolved under the /importing/ program's+-- own substitution, which is what makes forwarding (@%ctx.payload@, still a+-- hole) and supplying (@%Json@, a closed argument) both fall out of the same+-- code path.+--+-- __Canonical ids and the library segment.__ v4-types \S3's grammar renders+-- a 'Ref' as @library ":" name@ with @library@ inserted directly, and its+-- worked examples (@message:Envelope@) do exactly that. But a library key is+-- an arbitrary 'staticString' (see "Tramaj.Parser"), and \S3 requires+-- injectivity: two distinct types must never render to the same string.+-- Inserting an arbitrary key raw is safe on one side, because a 'name' is+-- always a colon-free identifier (see "Tramaj.Parser"'s @typeField@) --+-- reconstructing @library@ and @name@ from @library <> \":\" <> name@ is+-- therefore unambiguous however many colons @library@ itself contains. The+-- side that is /not/ safe is the program being resolved itself: a+-- declaration with no importing library at all (an ordinary @type X = ...@+-- at the root) needs some token for "no library", and no plain word is safe+-- for that -- a library can legally be named @\"root\"@, or even @\"\"@,+-- since 'staticString' forbids only a literal @\"@ or a backtick.+--+-- The fix follows from that one forbidden character: 'renderLibrary' wraps+-- every real library key in a literal pair of quotes (safe, and injective,+-- precisely because a key can never itself contain one), and reserves the+-- bare, unquoted word @root@ for "this program, not a library" -- a token no+-- quoted key can ever equal, because a quoted key always begins with @\"@.+-- This is a deliberate departure from \S3's unquoted worked examples, which+-- never exercise a program that is not itself an importable library; nothing+-- in the grammar there rules quoting out, and nothing else in it is+-- injective without it.+module Tramaj.Types+  ( ResolvedType (..)+  , ResolvedConstraintArg (..)+  , TypeError (..)+  , resolveTypeExpr+  , canonicalId+  , programTypeDecls+  , requireClosed+  , checkTypeParamCollisions+  , typeClosure+  , eraseTypes+  , typeReferences+  , deepTypeReferences+  , typeConstraints+  , deepTypeConstraints+  , programTypeRoots+  ) where++import Data.List (sortOn)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Tramaj.Analysis (everywhereIn, transitiveImportNames, typeExprsIn, typeParamCollisions, typeParams)+import Tramaj.Ast++-- | The normal form a 'TypeExpr' resolves to (v4-types \S3). Structurally the+-- same six shapes as 'TypeExpr', but every reference is now a genuine+-- @(library, name)@ pair rather than a name that might not exist, record+-- fields and union arms are sorted by name, a 'RRef' carries its resolved+-- type /arguments/ (roadmap Phase 10) rather than none, and a 'RRef' never+-- carries its referent's expansion -- only 'resolveTypeExpr' ever looks a+-- name up, and it looks up only whether the name exists, never what it+-- means.+--+-- 'Nothing' as a 'RRef' library means "declared in the program being+-- resolved, not reached through an import" -- see the module header for why+-- this needs a real 'Maybe' here rather than folding straight to a string:+-- the encoding decision belongs to 'canonicalId' alone, so a 'ResolvedType'+-- can be compared with '==' before any string is ever built.+data ResolvedType+  = RPrim Text+  | RArray ResolvedType+  | RRecord [(Text, ResolvedType)]+  | RUnion [(Text, Maybe ResolvedType)]+  | RRef (Maybe Text) Text [(Text, ResolvedType)]+  | RVar [Text]+  deriving stock (Eq, Ord, Show)++-- | v4-types \S10's analysis errors.+data TypeError+  = -- | A name resolved to neither a primitive (the parser already+    -- classifies those as 'TPrim') nor a declaration in the scope it was+    -- looked up in.+    UnresolvedType Text+  | -- | @$lib.types.X@ where @lib@ is not bound directly to an+    -- @import(...)@ in the enclosing chain -- reached through a lambda, an+    -- array, a later saturating call, or not bound at all -- or where that+    -- import names a library the table given to 'resolveTypeExpr' does not+    -- contain.+    NotStaticallyResolvable Text+  | -- | The root ships a type whose normal form still contains a variable+    -- (v4-types \S4): the resolved id, and the first unresolved path found+    -- in it.+    PartialType Text [Text]+  | -- | A params key is read both as @$ctx.k@ and as @%ctx.k@ (v4-types+    -- \S10, roadmap Phase 10).+    TypeParamCollision Text+  | -- | A declaration's *arguments* cycle through an import chain that never+    -- bottoms out -- a recursive body alone is never this (v4-types \S10).+    TypeCycle Text+  deriving stock (Eq, Show)++-- | Just the type declarations at the top of a program's own statement chain+-- (v4-types \S1.1), as a lookup table. This is 'typeDecls' plus 'unlets' plus+-- 'programRoot', named once because every entry point below needs it and+-- because a caller resolving several declarations from the same program+-- should not repeat the walk.+programTypeDecls :: Program -> Map Text TypeExpr+programTypeDecls = Map.fromList . typeDecls . fst . unlets . programRoot++-- | Resolves a 'TypeExpr' written somewhere in @prog@'s own statement chain+-- against @prog@'s own scope: its own declarations for a bare 'TName', and+-- the libraries in @libs@, reached through @prog@'s own direct @import(...)@+-- bindings, for a 'TLibRef' (v4-types \S9's @$lib.types.X@ rule). No library+-- in @libs@ is evaluated -- this walks parsed programs only, exactly as+-- "Tramaj.Analysis"\'s deep analyses do.+--+-- Structural shapes ('TArray', 'TRecord', 'TUnion') recurse; 'TVar' passes+-- through unchanged, since @prog@'s own declarations carry no substitution+-- of their own -- only a /reference/ to a parameterised library's+-- declaration, resolved from the referencing side, ever supplies one (see+-- 'resolveRef' below). A 'TName' or 'TLibRef' resolves to a 'RRef' that+-- carries no expansion of the declaration it names -- v4-types \S3's "stop+-- at declaration boundaries" clause, which is what keeps resolving a+-- self-recursive declaration's own body from looping: a 'TName' occurring+-- inside @Tree@'s own definition, referring to @Tree@ itself, is checked for+-- existence and rendered as a reference, never expanded.+resolveTypeExpr :: Map Text Program -> Program -> TypeExpr -> Either TypeError ResolvedType+resolveTypeExpr libs prog = resolveWith libs prog Map.empty Set.empty++-- | As 'resolveTypeExpr', but under a substitution ('subst', keyed by a+-- single-segment @%ctx@ variable's name) and a set of library keys ('visiting')+-- already being expanded on this chain, for 'TypeCycle' to check against+-- before expanding another. A supplied entry substitutes structurally --+-- v4-types \S6's "supply" -- while an unmatched 'TVar' stays a hole, exactly+-- what "forward" (\S6) needs when the substitution itself came from another+-- @%ctx.*@ read.+--+-- Only a single-segment path is ever substituted: v4-types has no notion of+-- projecting into a type parameter, so a longer path is left as a 'RVar'+-- rather than guessing at a meaning the spec does not give it.+resolveWith :: Map Text Program -> Program -> Map Text ResolvedType -> Set Text -> TypeExpr -> Either TypeError ResolvedType+resolveWith libs prog subst visiting = go+  where+    ownDecls = programTypeDecls prog+    ownStmts = fst (unlets (programRoot prog))++    go :: TypeExpr -> Either TypeError ResolvedType+    go (TPrim name) = Right (RPrim name)+    go (TArray t) = RArray <$> go t+    go (TRecord fields) = RRecord . sortOn fst <$> traverse resolveField fields+    go (TUnion arms) = RUnion . sortOn fst <$> traverse resolveArm arms+    go (TVar path@[k]) = Right (maybe (RVar path) id (Map.lookup k subst))+    go (TVar path) = Right (RVar path)+    go (TName name)+      | Map.member name ownDecls = Right (RRef Nothing name [])+      | otherwise = Left (UnresolvedType name)+    go (TLibRef libBinding name) = do+      (key, libProg, params) <- resolveLibBinding libs ownStmts libBinding+      if not (Map.member name (programTypeDecls libProg))+        then Left (UnresolvedType name)+        else+          if Set.member key visiting+            then Left (TypeCycle key)+            else do+              let visiting' = Set.insert key visiting+                  wanted = Set.map (\case (k : _) -> k; [] -> "") (typeParams libProg)+                  suppliedTypes = Map.fromList [(k, te) | (k, PType te) <- params]+                  -- | Every type parameter the target library has, not only+                  -- the ones this import happens to supply: an unsupplied+                  -- one still needs a slot in 'args', rendered as its own+                  -- 'RVar', so a caller resolving the reference sees the+                  -- same hole v4-types \S3's own worked example does+                  -- (@payload=%ctx.p@) rather than the argument silently+                  -- vanishing -- which is what let an unclosed 'RRef' slip+                  -- past 'requireClosed' before this comment was written.+                  argFor k = case Map.lookup k suppliedTypes of+                    Just te -> resolveWith libs prog subst visiting' te+                    Nothing -> Right (RVar [k])+              args <- sortOn fst <$> traverse (\k -> (,) k <$> argFor k) (Set.toList wanted)+              pure (RRef (Just key) name args)++    resolveField :: (Text, TypeExpr) -> Either TypeError (Text, ResolvedType)+    resolveField (name, t) = (,) name <$> go t++    resolveArm :: (Text, Maybe TypeExpr) -> Either TypeError (Text, Maybe ResolvedType)+    resolveArm (name, mt) = (,) name <$> traverse go mt++-- | @lib@ must be bound, in @stmts@, directly to an @import("key", ...)@ --+-- not to anything that merely evaluates to one -- and @key@ must be present+-- in @libs@. Takes the *last* such binding if @lib@ is somehow bound more+-- than once: an ordinary program never rebinds an import's name, so this is+-- a simplification rather than a real scoping rule, and nothing here needs+-- the precise lexical-shadowing behaviour 'Let' itself has.+--+-- Returns the resolved @key@ and the import's own params alongside the+-- library's 'Program' -- roadmap Phase 10 needs the params to build a+-- 'RRef'\'s @arguments@, and returning the key rather than just the+-- 'Program' is what keeps a caller from reaching for the wrong identity+-- (v4-types \S1.1: a reference's identity is the import's *table key*, not+-- the local name @lib@ happens to bind it to).+resolveLibBinding :: Map Text Program -> [Stmt] -> Text -> Either TypeError (Text, Program, [(Text, ParamValue)])+resolveLibBinding libs stmts lib = case directImportBinding stmts lib of+  Nothing -> Left (NotStaticallyResolvable lib)+  Just (key, params) -> case Map.lookup key libs of+    Nothing -> Left (NotStaticallyResolvable lib)+    Just libProg -> Right (key, libProg, params)++directImportBinding :: [Stmt] -> Text -> Maybe (Text, [(Text, ParamValue)])+directImportBinding stmts lib = case [(key, params) | SLet n (Import key params) <- stmts, n == lib] of+  [] -> Nothing+  bindings -> Just (last bindings)++-- | v4-types \S3's grammar, rendered. Assumes its argument is already+-- normalised the way 'resolveTypeExpr' produces it -- fields, arms and+-- arguments sorted by name -- since this function only renders the order it+-- is given; it does not sort.+canonicalId :: ResolvedType -> Text+canonicalId (RPrim name) = name+canonicalId (RArray t) = "[" <> canonicalId t <> "]"+canonicalId (RRecord fields) = "{" <> T.intercalate "," (map renderField fields) <> "}"+  where+    renderField (name, t) = name <> ":" <> canonicalId t+canonicalId (RUnion arms) = T.concat (map renderArm arms)+  where+    renderArm (name, Nothing) = "|" <> name+    renderArm (name, Just t) = "|" <> name <> " " <> canonicalId t+canonicalId (RRef lib name args) =+  renderLibrary lib <> ":" <> name <> if null args then "" else "[" <> T.intercalate "," (map renderArg args) <> "]"+  where+    renderArg (k, t) = k <> "=" <> canonicalId t+-- | 'RVar'\'s path, like 'Demand'\'s, excludes the leading @ctx@ segment it+-- is always rooted at -- 'Tramaj.Ast.Demand' and 'Tramaj.Eval.evalDemand'\'s+-- @sid = \"#ctx\" <> ...@ are the value-domain precedent this mirrors, with+-- @%@ standing in for @#@ since this is the type realm, not the symbol one+-- -- so it is reinserted here to render v4-types \S3's @var ::= \"%\" path@,+-- whose own worked example (@payload=%ctx.p@) spells it out in full.+canonicalId (RVar path) = "%ctx" <> T.concat (map ("." <>) path)++-- | See the module header for why a real library is quoted and "no library"+-- is the one bareword no quoted key can equal.+renderLibrary :: Maybe Text -> Text+renderLibrary Nothing = "root"+renderLibrary (Just key) = "\"" <> key <> "\""++-- | Whether a normal form still contains a 'RVar' anywhere -- inside a+-- 'RRef'\'s own arguments included, since an unfilled argument is exactly as+-- partial as a bare hole (v4-types \S4).+containsVar :: ResolvedType -> Bool+containsVar (RVar _) = True+containsVar (RArray t) = containsVar t+containsVar (RRecord fields) = any (containsVar . snd) fields+containsVar (RUnion arms) = any (maybe False containsVar . snd) arms+containsVar (RRef _ _ args) = any (containsVar . snd) args+containsVar (RPrim _) = False++-- | The path of the first 'RVar' found, left-to-right -- what 'PartialType'+-- reports alongside the id, so the error names a concrete hole rather than+-- only the type that has one.+firstVarPath :: ResolvedType -> [Text]+firstVarPath (RVar path) = path+firstVarPath (RArray t) = firstVarPath t+firstVarPath (RRecord fields) = case filter (containsVar . snd) fields of+  (_, t) : _ -> firstVarPath t+  [] -> error "unreachable: firstVarPath called on a type with no variable"+firstVarPath (RUnion arms) = case [t | (_, Just t) <- arms, containsVar t] of+  t : _ -> firstVarPath t+  [] -> error "unreachable: firstVarPath called on a type with no variable"+firstVarPath (RRef _ _ args) = case filter (containsVar . snd) args of+  (_, t) : _ -> firstVarPath t+  [] -> error "unreachable: firstVarPath called on a type with no variable"+firstVarPath (RPrim _) = error "unreachable: firstVarPath called on a type with no variable"++-- | v4-types \S4: a type reaching the root -- an annotation (roadmap Phase+-- 11), the closure of a program's own output (Phase 13) -- must be closed.+-- Everything else may stay partial; only a caller at the root need ever call+-- this.+requireClosed :: ResolvedType -> Either TypeError ResolvedType+requireClosed rt+  | containsVar rt = Left (PartialType (canonicalId rt) (firstVarPath rt))+  | otherwise = Right rt++-- | v4-types \S10's @TypeParamCollision@, surfaced as a proper 'TypeError'+-- from 'Tramaj.Analysis.typeParamCollisions'\' plain 'Data.Set.Set'.+-- Reports the first colliding key found, the way every other check here+-- reports one concrete failure rather than the whole set.+checkTypeParamCollisions :: Program -> Either TypeError ()+checkTypeParamCollisions prog = case Set.toList (typeParamCollisions prog) of+  (k : _) -> Left (TypeParamCollision k)+  [] -> Right ()++-- Output: the transitive closure of referenced types (v4-types \S8, roadmap+-- Phase 13) --------------------------------------------------------------++-- | Every 'RRef' reachable from a resolved type, including inside another+-- 'RRef'\'s own arguments -- what a caller must expand to build the+-- @\"types\"@ table's next layer.+collectRefs :: ResolvedType -> [ResolvedType]+collectRefs r@(RRef _ _ args) = r : concatMap (collectRefs . snd) args+collectRefs (RArray t) = collectRefs t+collectRefs (RRecord fields) = concatMap (collectRefs . snd) fields+collectRefs (RUnion arms) = concatMap (maybe [] collectRefs . snd) arms+collectRefs (RPrim _) = []+collectRefs (RVar _) = []++-- | The program and raw declaration body a 'RRef' names -- @Nothing@ means+-- @prog@ itself (v4-types \S1.1); @Just key@ means whatever program @key@+-- names in @libs@, exactly as 'resolveLibBinding' would have found it, but+-- starting from the resolved reference rather than the syntax that produced+-- it.+lookupDecl :: Map Text Program -> Program -> Maybe Text -> Text -> Either TypeError (Program, TypeExpr)+lookupDecl _ prog Nothing name =+  maybe (Left (UnresolvedType name)) (\t -> Right (prog, t)) (Map.lookup name (programTypeDecls prog))+lookupDecl libs _ (Just key) name = case Map.lookup key libs of+  Nothing -> Left (NotStaticallyResolvable key)+  Just libProg -> maybe (Left (UnresolvedType name)) (\t -> Right (libProg, t)) (Map.lookup name (programTypeDecls libProg))++-- | The transitive closure of every type referenced from @roots@ (v4-types+-- \S8): a record's field types, a union's payloads, and theirs, cut by id so+-- a cycle terminates. Each 'RRef' found is expanded exactly once -- its+-- declaration's own body, resolved under the substitution its arguments+-- supply -- which is the one place in this module a declaration boundary+-- /is/ crossed, because the output table is precisely where a host needs the+-- definition behind an id, not merely the id.+--+-- Keyed by canonical id rather than by @(library, name)@: two applications+-- of the same generic library at different arguments are two different+-- entries, exactly as \S3 says they are two different types.+typeClosure :: Map Text Program -> Program -> [ResolvedType] -> Either TypeError (Map Text ResolvedType)+typeClosure libs prog roots = go Map.empty (concatMap collectRefs roots)+  where+    go acc [] = Right acc+    go acc (r@(RRef libKey name args) : rest)+      | Map.member (canonicalId r) acc = go acc rest+      | otherwise = do+          (declProg, declBody) <- lookupDecl libs prog libKey name+          def <- resolveWith libs declProg (Map.fromList args) Set.empty declBody+          go (Map.insert (canonicalId r) def acc) (rest <> collectRefs def)+    go acc (_ : rest) = go acc rest++-- Erasure (v4-types \S7, roadmap Phase 11) --------------------------------++-- | Rewrites every 'TypeAnnotate' in @prog@ into the 'Let' plus 'Emit' \S7+-- specifies, resolving and closing its type first (an annotation whose type+-- is partial is 'PartialType', per \S7's own note that this is what makes+-- erasure safe). Everything else is rebuilt unchanged; a 'TypeDecl' and a+-- resolved 'TypeEmit' are left in place rather than stripped, since both are+-- already inert to 'Tramaj.Eval.evalExpr' -- only 'TypeAnnotate' produces+-- something the evaluator cannot already ignore on its own.+--+-- Run once, up front, by every one of "Tramaj.Eval"\'s entry points+-- (including a library, the moment it loads) rather than baked into+-- evaluation itself -- this is what keeps @Value@ free of a type+-- constructor and the whole \S1.5 @NotConcrete@ table untouched: by the time+-- 'Tramaj.Eval.evalExpr' runs, there is no 'TypeAnnotate' left for it to+-- match, and the byte-identical-to-annotations-deleted invariant \S8 asks+-- for follows from erasure alone, nothing evaluation-specific.+eraseTypes :: Map Text Program -> Program -> Either TypeError Program+eraseTypes libs prog = do+  root' <- eraseExpr libs prog (programRoot prog)+  pure $ case prog of+    DocumentProgram _ -> DocumentProgram root'+    ExpressionProgram _ -> ExpressionProgram root'++eraseExpr :: Map Text Program -> Program -> Expr -> Either TypeError Expr+eraseExpr libs prog = go+  where+    go :: Expr -> Either TypeError Expr+    go e@(Path _ _) = pure e+    go (FieldAccess target fields) = flip FieldAccess fields <$> go target+    go (Call fn args) = Call <$> go fn <*> traverse go args+    go (Lambda params body) = Lambda params <$> go body+    go (Let name value body) = Let name <$> go value <*> go body+    go e@(StringLit _) = pure e+    go e@(NumberLit _) = pure e+    go e@(BoolLit _) = pure e+    go NullLit = pure NullLit+    go (ArrayLit elems) = ArrayLit <$> traverse go elems+    go (ObjectLit entries) = ObjectLit <$> traverse (\(k, e) -> (,) k <$> go e) entries+    go (Element tag attrs val children) =+      Element tag <$> traverse goAttr attrs <*> go val <*> traverse go children+    go (Fragment children) = Fragment <$> traverse go children+    go (Branch c t e) = Branch <$> go c <*> go t <*> go e+    go (Map coll fn) = Map <$> go coll <*> go fn+    go (Filter coll fn) = Filter <$> go coll <*> go fn+    go (Scan coll initial fn) = Scan <$> go coll <*> go initial <*> go fn+    go (Fold coll initial fn) = Fold <$> go coll <*> go initial <*> go fn+    go (Concat l r) = Concat <$> go l <*> go r+    go (Import name params) = Import name <$> traverse goParam params+    go (AdaptActions target adaptation fn) = AdaptActions <$> go target <*> pure adaptation <*> traverse go fn+    go (Constrain name args) = Constrain name <$> traverse go args+    go (Emit constraint body) = Emit <$> go constraint <*> go body+    go (Alloc site keyExpr) = Alloc site <$> go keyExpr+    go e@(Demand _) = pure e+    go (TypeDecl name t body) = TypeDecl name t <$> go body+    go (TypeAnnotate name t valueExpr body) = do+      rt <- resolveTypeExpr libs prog t >>= requireClosed+      value' <- go valueExpr+      body' <- go body+      let hasType = Constrain "has-type" [Path name [], ObjectLit [("$type", StringLit (canonicalId rt))]]+      pure (Let name value' (Emit hasType body'))+    go (TypeEmit _ _ body) = go body++    goAttr (Attr name e) = Attr name <$> go e+    goAttr (ActionAttr event key e) = ActionAttr event key <$> go e++    goParam (k, PExpr e) = (,) k . PExpr <$> go e+    goParam kv@(_, PFromContext _) = pure kv+    goParam kv@(_, PType _) = pure kv++-- Type constraints (v4-types \S5, roadmap Phase 12) -----------------------++-- | A resolved @!type-constraint@ argument: a type, or one of the four+-- scalar shapes \S5 allows -- the type-realm counterpart of the+-- already-evaluated 'Value'' a v3 constraint's argument becomes.+data ResolvedConstraintArg+  = RCType ResolvedType+  | RCScalarStr Text+  | RCScalarNum Double+  | RCScalarBool Bool+  | RCScalarNull+  deriving stock (Eq, Ord, Show)++resolveConstraintArg :: Map Text Program -> Program -> TypeConstraintArg -> Either TypeError ResolvedConstraintArg+resolveConstraintArg libs prog (TCType t) = RCType <$> resolveTypeExpr libs prog t+resolveConstraintArg _ _ (TCScalarStr s) = Right (RCScalarStr s)+resolveConstraintArg _ _ (TCScalarNum n) = Right (RCScalarNum n)+resolveConstraintArg _ _ (TCScalarBool b) = Right (RCScalarBool b)+resolveConstraintArg _ _ TCScalarNull = Right RCScalarNull++-- | Every @!type-constraint@ this program's own statement chain collects+-- (v4-types \S5), each argument resolved, deduplicated by name and+-- already-resolved arguments -- the same "first position kept" rule v3 \S4+-- uses for value constraints, applied here because instantiation+-- (substitution through a supplied argument) can make two differently+-- written constraints collide the same way two differently written value+-- constraints can.+typeConstraints :: Map Text Program -> Program -> Either TypeError [(Text, [ResolvedConstraintArg])]+typeConstraints libs prog = do+  raw <- traverse resolveOne (everywhereIn collectTypeEmits prog)+  pure (dedupeFirst raw)+  where+    collectTypeEmits (TypeEmit name args _) = [(name, args)]+    collectTypeEmits _ = []+    resolveOne (name, args) = (,) name <$> traverse (resolveConstraintArg libs prog) args++-- | 'typeConstraints', over-approximated by following every transitively+-- imported library (roadmap Phase 12\/14) -- the type-constraint analogue of+-- 'Tramaj.Analysis.deepConstraintKinds': a constraint written inside a+-- library that this program imports is reported whether or not the+-- program's own evaluation would ever force that library, since a+-- @!type-constraint@ is never evaluated in the first place and so has no+-- notion of "reached" to restrict it by.+deepTypeConstraints :: Map Text Program -> Program -> Either TypeError [(Text, [ResolvedConstraintArg])]+deepTypeConstraints libs prog = do+  own <- typeConstraints libs prog+  fromLibs <- concat <$> traverse fromLib (Set.toList (transitiveImportNames libs prog))+  pure (dedupeFirst (own <> fromLibs))+  where+    fromLib name = maybe (Right []) (typeConstraints libs) (Map.lookup name libs)++dedupeFirst :: (Eq a) => [a] -> [a]+dedupeFirst = go []+  where+    go _ [] = []+    go seen (x : xs)+      | x `elem` seen = go seen xs+      | otherwise = x : go (x : seen) xs++-- Type references (v4-types \S9, roadmap Phase 14) ------------------------++-- | Every type this program's own statement chain refers to, normalised to+-- its canonical id (v4-types \S9: "which it refers to, normalised") --+-- every declaration, annotation and type-constraint argument's own type,+-- resolved. An unresolvable reference is reported rather than skipped+-- (\S9's closing rule), which is exactly what 'resolveTypeExpr' already+-- does by returning an 'Either'.+typeReferences :: Map Text Program -> Program -> Either TypeError (Set Text)+typeReferences libs prog = Set.fromList . map canonicalId <$> programTypeRoots libs prog++-- | Every 'TypeExpr' sitting in a type-bearing position of @prog@'s own+-- syntax -- a declaration's body, an annotation's type, a type constraint's+-- type-marked arguments, an import's @%@-marked param (v4-types \S2, \S5,+-- \S7, \S9) -- resolved. This is 'typeReferences' before the last step that+-- throws the structure away down to a set of ids; "Tramaj.Eval" needs the+-- structure itself to build the @\"types\"@ output table's closure+-- (v4-types \S8, roadmap Phase 13), and 'typeReferences' needs only the ids.+programTypeRoots :: Map Text Program -> Program -> Either TypeError [ResolvedType]+programTypeRoots libs prog = traverse (resolveTypeExpr libs prog) (everywhereIn typeExprsIn prog)++-- | 'typeReferences', following every transitively imported library --+-- the type-realm analogue of 'Tramaj.Analysis.deepContextHoles'.+deepTypeReferences :: Map Text Program -> Program -> Either TypeError (Set Text)+deepTypeReferences libs prog = do+  own <- typeReferences libs prog+  fromLibs <- traverse fromLib (Set.toList (transitiveImportNames libs prog))+  pure (Set.unions (own : fromLibs))+  where+    fromLib name = maybe (Right Set.empty) (typeReferences libs) (Map.lookup name libs)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,226 @@+-- | The three analyses @../specs/laws.md@ asks to be cheap: which imports a+-- program uses, which actions it can emit, and which context values it still+-- needs.+--+-- Every case here answers its question from the AST alone -- no context, no+-- library evaluation, no host code. That is the property being protected: if+-- one of these ever needed to run a program to answer, a static position in+-- the grammar has been given up somewhere.+module Tramaj.AnalysisSpec (spec) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import Test.Hspec+import Tramaj.Analysis+import Tramaj.Ast (Program)+import Tramaj.Parser++spec :: Spec+spec = do+  importSpec+  actionSpec+  holeSpec+  constraintSpec+  symbolSpec+  typeParamSpec++prog :: Text -> Program+prog src = either (\e -> error ("analysis fixture does not parse: " <> show e)) id (parseProgram src)++libs :: Map.Map Text Program+libs =+  Map.fromList+    [ ("button", prog ".button(action(\"on-click\", \"deploy\", {}))")+    , ("row", prog ".tr(action(\"on-click\", \"select\", {}), import(\"button\", {}).rendered)")+    , ("needs", prog "@p=import(\"button\", {name: ctx(inner.name)})\n$p({}).rendered")+    , ("panel", prog "@n=$ctx.replicas\n.section(.h2($ctx.name), .p($n))")+    , ("loopy", prog ".div(import(\"loopy\", {}).rendered)")+    , ("typed", prog "!constraint(\"has-type\", $ctx, \"Deployment\")\n1")+    ]++importSpec :: Spec+importSpec = describe "imports" $ do+  it "finds every directly imported name" $+    staticImportNames (prog "@a=import(\"x\", {})\n.div(import(\"y\", {}).rendered)")+      `shouldBe` Set.fromList ["x", "y"]++  it "finds names inside lambdas, branches and unreached arms alike" $+    staticImportNames (prog "@f=(z) => import(\"deep\", {}).rendered\n.div(branch(.p(\"a\"), false, import(\"unreached\", {}).rendered))")+      `shouldBe` Set.fromList ["deep", "unreached"]++  it "finds none in a program that imports nothing" $+    staticImportNames (prog ".div(\"plain\")") `shouldBe` Set.empty++  it "follows imports transitively" $+    transitiveImportNames libs (prog ".div(import(\"row\", {}).rendered)")+      `shouldBe` Set.fromList ["row", "button"]++  it "reports an imported name that the table cannot resolve" $+    transitiveImportNames libs (prog ".div(import(\"missing\", {}).rendered)") `shouldBe` Set.fromList ["missing"]++  it "terminates on a cycle" $+    transitiveImportNames libs (prog ".div(import(\"loopy\", {}).rendered)") `shouldBe` Set.fromList ["loopy"]++actionSpec :: Spec+actionSpec = describe "action keys" $ do+  it "finds every key an element declares" $+    staticActionKeys (prog ".div(.b(action(\"on-click\", \"save\", {})), .b(action(\"on-key\", \"delete\", {})))")+      `shouldBe` Set.fromList ["save", "delete"]++  it "finds keys under an unreached branch arm, since the analysis approximates upward" $+    staticActionKeys (prog ".div(branch(.p(\"a\"), false, .b(action(\"on-click\", \"never\", {}))))")+      `shouldBe` Set.fromList ["never"]++  -- The payoff of restricting adaptation to identity-or-prefix: the analysis+  -- applies the very same rewrite the evaluator will.+  it "applies a prefix adaptation to the keys of its target" $+    staticActionKeys (prog "adapt-actions(.div(.b(action(\"on-click\", \"save\", {})), .b(action(\"on-click\", \"delete\", {}))), prefix(\"user:\"))")+      `shouldBe` Set.fromList ["user:save", "user:delete"]++  it "composes nested adaptations the way evaluation does" $+    staticActionKeys (prog "adapt-actions(adapt-actions(.b(action(\"on-click\", \"k\", {})), prefix(\"a:\")), prefix(\"b:\"))")+      `shouldBe` Set.fromList ["b:a:k"]++  it "leaves keys alone under the identity adaptation" $+    staticActionKeys (prog "adapt-actions(.b(action(\"on-click\", \"k\", {})), identity)") `shouldBe` Set.fromList ["k"]++  it "does not reach into a library on its own" $+    staticActionKeys (prog ".div(import(\"button\", {}).rendered)") `shouldBe` Set.empty++  it "reaches into a library when given the table" $+    deepActionKeys libs (prog ".div(import(\"button\", {}).rendered)") `shouldBe` Set.fromList ["deploy"]++  it "adapts keys that come from a library" $+    deepActionKeys libs (prog "adapt-actions(import(\"button\", {}).rendered, prefix(\"deployment:\"))")+      `shouldBe` Set.fromList ["deployment:deploy"]++  it "follows imports through several levels" $+    deepActionKeys libs (prog ".div(import(\"row\", {}).rendered)") `shouldBe` Set.fromList ["select", "deploy"]++  it "cuts a cycle rather than looping" $+    deepActionKeys libs (prog ".div(import(\"loopy\", {}).rendered)") `shouldBe` Set.empty++holeSpec :: Spec+holeSpec = describe "context holes" $ do+  it "finds the paths written as ctx(...)" $+    contextHoles (prog "@p=import(\"dep\", {\"name\": \"web\", \"replicas\": ctx(spec.replicas)})\n$p({}).rendered")+      `shouldBe` Set.fromList [["spec", "replicas"]]++  it "finds several holes across several imports" $+    contextHoles (prog "@a=import(\"x\", {n: ctx(one)})\n@b=import(\"y\", {m: ctx(two.deep)})\n.div($a({}).rendered, $b({}).rendered)")+      `shouldBe` Set.fromList [["one"], ["two", "deep"]]++  -- The same read, spelled as an ordinary path. It is a context read, but+  -- not a declared hole -- which is the whole reason @ctx(...)@ is a+  -- separate node when it evaluates identically.+  it "does not count a parameter read as $ctx.path" $+    contextHoles (prog "import(\"dep\", {\"replicas\": $ctx.spec.replicas}).rendered") `shouldBe` Set.empty++  it "finds none in a program with no imports" $+    contextHoles (prog ".div(\"plain\")") `shouldBe` Set.empty++  it "bubbles up the holes of imported libraries" $+    deepContextHoles libs (prog ".div(import(\"needs\", {}).rendered)")+      `shouldBe` Set.fromList [["inner", "name"]]++  it "counts both spellings as context reads" $+    contextReads (prog "@a=$ctx.x\nimport(\"dep\", {r: ctx(spec.replicas)}).rendered")+      `shouldBe` Set.fromList [["x"], ["spec", "replicas"]]++  it "counts a bare $ctx as reading the whole context" $+    contextReads (prog "$ctx") `shouldBe` Set.fromList [[]]++  -- What a library reads and the import never supplies: the parameters+  -- that have to arrive by a later call, without running anything.+  it "finds the parameters an import has not supplied" $+    unsuppliedParams libs (prog "import(\"panel\", {\"name\": \"web\"}).rendered")+      `shouldBe` [("panel", Set.fromList [["replicas"]])]++  it "finds nothing unsupplied when every read is covered" $+    unsuppliedParams libs (prog "import(\"panel\", {name: ctx(n), \"replicas\": 3}).rendered")+      `shouldBe` [("panel", Set.empty)]++  it "reports nothing unsupplied for a library outside the table" $+    unsuppliedParams libs (prog "import(\"nope\", {}).rendered") `shouldBe` [("nope", Set.empty)]++constraintSpec :: Spec+constraintSpec = describe "constraint kinds" $ do+  it "finds every constraint name a program can emit" $+    constraintKinds (prog "!constraint(\"gte\", 1, 0)\n!constraint(\"lte\", 1, 10)\n1")+      `shouldBe` Set.fromList ["gte", "lte"]++  it "finds a kind emitted only under an unreached branch arm, since the analysis approximates upward" $+    constraintKinds (prog "!branch(constraint(\"never\"), true, 1)\n1")+      `shouldBe` Set.fromList ["never"]++  it "finds none in a program that emits nothing" $+    constraintKinds (prog "1") `shouldBe` Set.empty++  it "does not reach into a library on its own" $+    constraintKinds (prog "import(\"typed\", {}).rendered") `shouldBe` Set.empty++  it "reaches into a library when given the table" $+    deepConstraintKinds libs (prog "import(\"typed\", {}).rendered") `shouldBe` Set.fromList ["has-type"]++  it "cuts a cycle rather than looping" $+    deepConstraintKinds libs (prog ".div(import(\"loopy\", {}).rendered)") `shouldBe` Set.empty++symbolSpec :: Spec+symbolSpec = describe "symbol sites" $ do+  it "finds every allocation site a program contains" $+    symbolSites (prog "[?(\"a\"), ?(\"b\")]") `shouldBe` Set.fromList [0, 1]++  it "finds none in a program that allocates nothing" $+    symbolSites (prog "1") `shouldBe` Set.empty++  it "finds a site inside a lambda" $+    symbolSites (prog "map($ctx.xs, (x) => ?($x))") `shouldBe` Set.fromList [0]++  it "is non-empty for a program that cannot serve as a library" $+    symbolSites (prog "?(\"x\")") `shouldNotBe` Set.empty++  it "finds every ?ctx.path demand directly" $+    symbolDemands (prog "[?ctx.a, ?ctx.b.c]") `shouldBe` Set.fromList [["a"], ["b", "c"]]++  it "finds none in a program with no demand" $+    symbolDemands (prog "$ctx.a") `shouldBe` Set.empty++  it "does not reach into a library on its own" $+    symbolDemands (prog "import(\"withDemand\", {}).rendered") `shouldBe` Set.empty++  it "bubbles up demands from an imported library" $+    deepSymbolDemands (Map.insert "withDemand" (prog "?ctx.threshold") libs) (prog "import(\"withDemand\", {}).rendered")+      `shouldBe` Set.fromList [["threshold"]]++-- v4-types \S9-\S10, roadmap Phase 10 -------------------------------------------++typeParamSpec :: Spec+typeParamSpec = describe "type declarations and parameters" $ do+  it "finds every type this program declares" $+    typeDeclarations (prog "type A = string\ntype B = number\ntrue") `shouldBe` Set.fromList ["A", "B"]++  it "is empty for a program with no type declaration" $+    typeDeclarations (prog "1") `shouldBe` Set.empty++  it "finds a %ctx.* path inside a declaration's own body" $+    typeParams (prog "type Message = { payload : %ctx.payload }\ntrue") `shouldBe` Set.fromList [["payload"]]++  it "finds a %ctx.* path forwarded through an import parameter, with no type declaration at all" $+    typeParams (prog "@in=import(\"inner\", {payload: %ctx.payload})\ntrue") `shouldBe` Set.fromList [["payload"]]++  it "finds a %ctx.* path inside a !type-constraint argument" $+    typeParams (prog "!type-constraint(\"has-default\", %ctx.payload)\ntrue") `shouldBe` Set.fromList [["payload"]]++  it "finds a %ctx.* path inside an annotation" $+    typeParams (prog "@x : %ctx.t = 1\ntrue") `shouldBe` Set.fromList [["t"]]++  it "reports which type params an import leaves unsupplied" $+    let typedLibs = Map.singleton "message" (prog "type Envelope = { payload : %ctx.payload }\ntrue")+     in unsuppliedTypeParams typedLibs (prog "@msg=import(\"message\", {})\ntrue")+          `shouldBe` [("message", Set.fromList [["payload"]])]++  it "reports nothing unsupplied once the import supplies the param" $+    let typedLibs = Map.singleton "message" (prog "type Envelope = { payload : %ctx.payload }\ntrue")+     in unsuppliedTypeParams typedLibs (prog "@msg=import(\"message\", {payload: %string})\ntrue")+          `shouldBe` [("message", Set.empty)]

@@ -0,0 +1,149 @@+-- | Runs the shared cross-implementation corpus at @corpus/cases@ (see+-- @corpus/README.md@), the counterpart of @tramaj/test/Test/Main.purs@'s+-- @runCorpus@. A case here is byte-equality between two independently+-- written implementations, not merely "this implementation agrees with+-- itself" -- see @roadmap-to-v4@ Phase 0.+module Tramaj.CorpusSpec (spec) where++import Control.Monad (filterM, forM)+import Data.Aeson (FromJSON (..), Value (..), eitherDecodeStrict, encode, withObject, (.:), (.:?))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.List (isSuffixOf, sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import System.Directory (canonicalizePath, doesDirectoryExist, listDirectory)+import System.FilePath (dropExtension, takeFileName, (</>))+import Test.Hspec+import Tramaj.Eval (EvalError, LibraryTable, Mode (..), evalProgram, runProgram)+import Tramaj.Parser (parseProgram)++-- | `"kind"` is part of the format (corpus/README.md) but not read here: a+-- successful run's shape is checked by comparing against @expected.json@+-- wholesale, via 'runProgram', which already reflects the mode and (once §4+-- lands) the kind in what it produces.+data CaseMeta = CaseMeta+  { metaName :: Text+  , metaMode :: Text+  , metaExpect :: Text+  , metaErrorKind :: Maybe Text+  }++instance FromJSON CaseMeta where+  parseJSON = withObject "meta.json" $ \o ->+    CaseMeta <$> o .: "name" <*> o .: "mode"+      <*> (fromMaybe "success" <$> o .:? "expect")+      <*> o .:? "errorKind"++spec :: Spec+spec = do+  root <- runIO findCorpusRoot+  cases <- runIO (loadCaseDirs root)+  describe "shared corpus" $+    mapM_ (\dir -> it (takeFileName dir) (runCase dir)) cases++-- | The corpus lives at @corpus/cases@ relative to the repo root, but+-- @cabal test@'s working directory depends on how it is invoked -- walk+-- upward until it is found.+findCorpusRoot :: IO FilePath+findCorpusRoot = go "."+  where+    go dir = do+      let candidate = dir </> "corpus" </> "cases"+      found <- doesDirectoryExist candidate+      if found+        then pure candidate+        else do+          -- `makeAbsolute` only prepends the cwd and normalises separators;+          -- it does not collapse `..` segments, so comparing its output+          -- against one accumulated `..` deeper never converges and this+          -- loop spun forever once corpus/cases was unreachable (e.g.+          -- running the test suite from a standalone sdist, which does not+          -- include the repo-root corpus/ directory). `canonicalizePath`+          -- resolves `..` (and symlinks) against the real filesystem, so+          -- `absHere == absUp` actually fires at the real root.+          absHere <- canonicalizePath dir+          absUp <- canonicalizePath (dir </> "..")+          if absHere == absUp+            then error "could not locate corpus/cases above the test working directory"+            else go (dir </> "..")++loadCaseDirs :: FilePath -> IO [FilePath]+loadCaseDirs root = do+  entries <- listDirectory root+  dirs <- filterM (doesDirectoryExist . (root </>)) entries+  pure (sort (map (root </>) dirs))++readJsonFile :: (FromJSON a) => FilePath -> IO a+readJsonFile path = do+  bytes <- BS.readFile path+  either (\e -> error (path <> ": " <> e)) pure (eitherDecodeStrict bytes)++readLibs :: FilePath -> IO LibraryTable+readLibs dir = do+  let libsDir = dir </> "libs"+  exists <- doesDirectoryExist libsDir+  if not exists+    then pure Map.empty+    else do+      files <- filter (".tramaj" `isSuffixOf`) <$> listDirectory libsDir+      entries <- forM files $ \f -> do+        src <- TE.decodeUtf8 <$> BS.readFile (libsDir </> f)+        let name = T.pack (dropExtension f)+        case parseProgram src of+          Left e -> error (libsDir </> f <> ": parse error: " <> show e)+          Right prog -> pure (name, prog)+      pure (Map.fromList entries)++modeFromMeta :: FilePath -> Text -> IO Mode+modeFromMeta dir m = case m of+  "concrete" -> pure Concrete+  "symbolic" -> pure Symbolic+  other -> error (dir <> ": unknown mode " <> T.unpack other)++runCase :: FilePath -> Expectation+runCase dir = do+  meta <- (readJsonFile (dir </> "meta.json") :: IO CaseMeta)+  mode <- modeFromMeta dir (metaMode meta)+  src <- TE.decodeUtf8 <$> BS.readFile (dir </> "template.tramaj")+  libs <- readLibs dir+  let label = T.unpack (metaName meta)+  case metaExpect meta of+    "parse-error" -> case parseProgram src of+      Left _ -> pure ()+      Right _ -> expectationFailure (label <> ": expected a parse error, but the template parsed")+    "eval-error" -> case metaErrorKind meta of+      Nothing -> expectationFailure (label <> ": eval-error case needs errorKind")+      Just errorKind -> do+        ctx <- (readJsonFile (dir </> "ctx.json") :: IO Value)+        case parseProgram src of+          Left e -> expectationFailure (label <> ": parse error: " <> show e)+          Right prog -> case evalProgram mode libs ctx prog of+            Right _ -> expectationFailure (label <> ": expected eval error " <> T.unpack errorKind <> ", but evaluation succeeded")+            Left e ->+              let actualKind = errorConstructor e+               in if actualKind == errorKind+                    then pure ()+                    else expectationFailure (label <> ": expected eval error " <> T.unpack errorKind <> ", got " <> T.unpack actualKind <> " (" <> show e <> ")")+    "success" -> do+      ctx <- (readJsonFile (dir </> "ctx.json") :: IO Value)+      expected <- (readJsonFile (dir </> "expected.json") :: IO Value)+      case parseProgram src of+        Left e -> expectationFailure (label <> ": parse error: " <> show e)+        Right prog -> case runProgram mode libs ctx prog of+          Left e -> expectationFailure (label <> ": eval error: " <> show e)+          Right actual -> encode actual `shouldBe` (encode expected :: BL.ByteString)+    other -> expectationFailure (label <> ": unknown expect " <> T.unpack other)++-- | The constructor name an 'EvalError''s 'Show' instance leads with -- every+-- constructor is written as @Name arg1 arg2 ...@, so the first+-- whitespace-delimited word is unambiguous. Kept to this rather than a+-- dedicated projection so a new 'EvalError' constructor needs no matching+-- addition here.+errorConstructor :: EvalError -> Text+errorConstructor e = case T.words (T.pack (show e)) of+  (w : _) -> w+  [] -> ""

@@ -0,0 +1,649 @@+-- | End-to-end evaluation: parse a program, run it against a context, check+-- what it produced.+--+-- The suite is organised by what each group is actually protecting, because+-- most of these behaviours are decisions rather than consequences and a+-- failure should say which decision broke. See @../specs/decisions.md@.+module Tramaj.EvalSpec (spec) where++import Data.Aeson (Value (..), object, (.=))+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Test.Hspec+import Tramaj.Ast (Program)+import Tramaj.Eval+import Tramaj.Node+import Tramaj.Parser+import Tramaj.Types (TypeError (..))++spec :: Spec+spec = do+  documentSpec+  scalarSpec+  displayStringSpec+  fragmentSpec+  actionSpec+  bindingSpec+  concatSpec+  branchSpec+  collectionSpec+  importSpec+  adaptSpec+  errorSpec+  typeSpec++-- Helpers -------------------------------------------------------------------++libs :: LibraryTable+libs =+  Map.fromList+    [ ("button", lib "@label=\"go: `$ctx.name`\"\n.button(action(\"on-click\", \"deploy\", {\"n\": $ctx.name}), $label)")+    , ("panel", lib "@n=$ctx.replicas\n.section(.h2($ctx.name), .p($n))")+    , ("two-actions", lib ".div(.b(action(\"on-click\", \"save\", {})), .b(action(\"on-click\", \"delete\", {})))")+    , ("data", lib "@a=1\n{\"a\": $a, \"b\": $ctx.b}")+    , ("wrapper", lib ".div(import(\"button\", {\"name\": \"inner\"}).rendered)")+    , ("loopy", lib ".div(import(\"loopy\", {}).rendered)")+    ]+  where+    lib :: Text -> Program+    lib src = either (\e -> error ("library fixture does not parse: " <> show e)) id (parseProgram src)++-- | Parse and evaluate, flattening a parse failure into the same 'Either' so+-- a fixture that stops parsing fails loudly instead of being skipped.+run :: Text -> Value -> Either String Output+run src ctx = case parseProgram src of+  Left e -> Left ("parse error: " <> show e)+  Right prog -> either (Left . show) Right (evalProgram Concrete libs ctx prog)++-- | The document a program produced, as its normative JSON -- what a host+-- receives, rather than the internal representation.+doc :: Text -> Value -> Either String Value+doc src ctx =+  run src ctx >>= \case+    ONode n -> Right (nodeToJson n)+    OValue v -> Left ("expected a document, got the value " <> show v)++val :: Text -> Value -> Either String Value+val src ctx =+  run src ctx >>= \case+    OValue v -> Right v+    ONode _ -> Left "expected a value, got a document"++failsWith :: (EvalError -> Bool) -> Text -> Value -> Bool+failsWith p src ctx = case parseProgram src of+  Left _ -> False+  Right prog -> either p (const False) (evalProgram Concrete libs ctx prog)++-- | Expected-node builders, matching @specs/node-json.md@.+elemJ :: Text -> [Value] -> [Value] -> Value -> Value+elemJ tag attrs children value =+  object+    [ "type" .= ("element" :: Text)+    , "tag" .= tag+    , "attributes" .= attrs+    , "value" .= value+    , "children" .= children+    , "annotations" .= object []+    ]++el :: Text -> [Value] -> Value+el tag children = elemJ tag [] children Null++-- | A JSON array, spelled as a list at the call site.+arr :: [Value] -> Value+arr = Array . V.fromList++textJ :: Value -> Value+textJ v = object ["type" .= ("text" :: Text), "value" .= v, "annotations" .= object []]++fragJ :: [Value] -> Value+fragJ children = object ["type" .= ("fragment" :: Text), "children" .= children, "annotations" .= object []]++attrJ :: Text -> Value -> Value+attrJ name v = object ["kind" .= ("attribute" :: Text), "name" .= name, "value" .= v]++actionJ :: Text -> Text -> Value -> Value+actionJ event key payload =+  object ["kind" .= ("action" :: Text), "event" .= event, "key" .= key, "payload" .= payload]++items :: [Text] -> Value+items names = object ["items" .= [object ["name" .= n] | n <- names]]++-- Documents -------------------------------------------------------------------++documentSpec :: Spec+documentSpec = describe "documents" $ do+  it "builds a nested element tree" $+    doc ".div(.p(\"Hello\"))" Null `shouldBe` Right (el "div" [el "p" [textJ (String "Hello")]])++  it "puts attributes and children in source order" $+    doc ".div(class: \"panel\", \"data-id\": 7, .h1(\"T\"), .p(\"B\"))" Null+      `shouldBe` Right+        ( elemJ+            "div"+            [attrJ "class" (String "panel"), attrJ "data-id" (Number 7)]+            [el "h1" [textJ (String "T")], el "p" [textJ (String "B")]]+            Null+        )++  it "keeps an attribute value as a value rather than a display string" $+    doc ".div(count: $ctx.n, tags: [1, 2], on: true)" (object ["n" .= (3 :: Int)])+      `shouldBe` Right+        ( elemJ+            "div"+            [attrJ "count" (Number 3), attrJ "tags" (arr [Number 1, Number 2]), attrJ "on" (Bool True)]+            []+            Null+        )++  it "fills the element value slot, defaulting to null" $ do+    doc ".Replicas(value($ctx.n))" (object ["n" .= (3 :: Int)]) `shouldBe` Right (elemJ "Replicas" [] [] (Number 3))+    doc ".Replicas()" Null `shouldBe` Right (elemJ "Replicas" [] [] Null)++  it "splices a document held in a binding rather than stringifying it" $+    doc "@header=.header(.h1(\"T\"))\n.main($header)" Null+      `shouldBe` Right (el "main" [el "header" [el "h1" [textJ (String "T")]]])++  it "renders a document returned from a lambda" $+    doc "@row=(x) => .li($x)\n.ul($row(\"a\"), $row(\"b\"))" Null+      `shouldBe` Right (el "ul" [el "li" [textJ (String "a")], el "li" [textJ (String "b")]])++  -- End to end, because the grammar checks in 'Tramaj.ParserSpec' cannot say+  -- that a stripped comment leaves the *output* alone -- and that a `--`+  -- inside a string reaches it intact.+  it "strips comments and keeps a `--` inside a string as text" $+    doc "-- a heading\n@n=cardinality($ctx.items) -- how many\n.p(\"`$n` -- so far\")"+      (object ["items" .= arr [String "a", String "b"]])+      `shouldBe` Right (el "p" [textJ (String "2 -- so far")])++-- Scalars ------------------------------------------------------------------------++-- | The decision that scalars survive evaluation: v1 stringified every child.+scalarSpec :: Spec+scalarSpec = describe "scalar children" $ do+  it "keeps a number child a number" $+    doc ".td($ctx.count)" (object ["count" .= (3 :: Int)]) `shouldBe` Right (el "td" [textJ (Number 3)])++  it "keeps booleans, null and objects unconverted" $+    doc ".div(true, null, {\"a\": 1})" Null+      `shouldBe` Right+        (el "div" [textJ (Bool True), textJ Null, textJ (object ["a" .= (1 :: Int)])])++  -- An array in child position is a sibling sequence, not one value: this is+  -- the same rule that lets map(...) produce repeated children, applied+  -- uniformly. An array wanted as data belongs in an attribute or the value+  -- slot, which is what those are for.+  it "splices an array child into siblings rather than nesting it as one value" $+    doc ".div([1, \"a\"])" Null `shouldBe` Right (el "div" [textJ (Number 1), textJ (String "a")])++  it "converts only where the source asks, through interpolation" $+    doc ".p(\"n is `$ctx.n`\")" (object ["n" .= (3 :: Int)])+      `shouldBe` Right (el "p" [textJ (String "n is 3")])++  it "renders a whole number without a trailing .0 when interpolated" $+    val "\"`$ctx.n`\"" (object ["n" .= (3 :: Int)]) `shouldBe` Right (String "3")++  it "resolves escape sequences" $+    val "\"a\\tb\\nc\\u{1F600}\"" Null `shouldBe` Right (String "a\tb\nc\128512")++-- | How @str@ -- and therefore string interpolation -- renders each kind of+-- value. This is a normative rendering that both implementations must+-- produce character for character, so every case here is pinned exactly+-- rather than described loosely; the numbers follow ECMAScript's+-- @Number::toString@, which is simply what a number's text is on the+-- PureScript implementation's host.+displayStringSpec :: Spec+displayStringSpec = describe "str" $ do+  let renders :: Text -> Text -> Spec+      renders src expected =+        it (T.unpack src <> " -> " <> show expected) $+          val ("str(" <> src <> ")") Null `shouldBe` Right (String expected)++  renders "\"hi\"" "hi"+  renders "null" ""+  renders "true" "true"+  renders "false" "false"++  renders "3" "3"+  renders "1.5" "1.5"+  renders "0.05" "0.05"+  renders "123456789" "123456789"++  -- v1 rendered this as "100000000000.0" on the PureScript side, whose+  -- integrality test went through a 32-bit Int.+  renders "100000000000" "100000000000"++  -- The thresholds where ECMAScript switches to scientific notation.+  renders "1000000000000000000000" "1e+21"+  renders "0.0000001" "1e-7"++  -- v1 rendered these through Haskell's own Show, leaking+  -- "Array [Number 1.0,Number 2.0]" into template output.+  renders "[1, 2]" "[1,2]"+  renders "{\"a\": 1}" "{\"a\":1}"++  -- Keys are sorted: object key order is not semantically significant, so+  -- it must not be observable here either.+  renders "{\"b\": 2, \"a\": [1, {\"c\": true}]}" "{\"a\":[1,{\"c\":true}],\"b\":2}"++  it "renders a nested string with JSON escaping, but a bare one raw" $ do+    val "str([\"a\\\"b\"])" Null `shouldBe` Right (String "[\"a\\\"b\"]")+    val "str(\"a\\\"b\")" Null `shouldBe` Right (String "a\"b")++  it "is what string interpolation uses" $+    val "\"n=`$ctx.xs`\"" (object ["xs" .= ([1, 2] :: [Int])]) `shouldBe` Right (String "n=[1,2]")++-- Fragments ---------------------------------------------------------------------++fragmentSpec :: Spec+fragmentSpec = describe "fragments" $ do+  it "introduces siblings with no wrapper element" $+    doc ".(.p(\"one\"), .p(\"two\"))" Null+      `shouldBe` Right (fragJ [el "p" [textJ (String "one")], el "p" [textJ (String "two")]])++  it "survives as a real node when nested, rather than being flattened" $+    doc ".div(.(.p(\"a\")))" Null `shouldBe` Right (el "div" [fragJ [el "p" [textJ (String "a")]]])++  -- The JSX-children case, and the reason documents had to become values.+  it "can be bound and passed to a lambda as an ordinary argument" $+    doc "@kids=.(.p(\"a\"), .p(\"b\"))\n@panel=(t, c) => .section(.h2($t), $c)\n$panel(\"T\", $kids)" Null+      `shouldBe` Right+        ( el+            "section"+            [ el "h2" [textJ (String "T")]+            , fragJ [el "p" [textJ (String "a")], el "p" [textJ (String "b")]]+            ]+        )++  it "can be returned from a lambda over a mapped collection" $+    doc "@bs=(xs) => .(map($xs, (x) => .button($x.name)))\n$bs($ctx.items)" (items ["a", "b"])+      `shouldBe` Right (fragJ [el "button" [textJ (String "a")], el "button" [textJ (String "b")]])++-- Actions -------------------------------------------------------------------------++actionSpec :: Spec+actionSpec = describe "actions" $ do+  it "carries structured event, key and payload" $+    doc ".b(action(\"on-click\", \"deploy\", {\"id\": $ctx.id}), \"Go\")" (object ["id" .= (1 :: Int)])+      `shouldBe` Right+        ( elemJ+            "b"+            [actionJ "on-click" "deploy" (object ["id" .= (1 :: Int)])]+            [textJ (String "Go")]+            Null+        )++  -- v1 allowed at most one action per element.+  it "allows several on one element, in source order alongside attributes" $+    doc ".b(class: \"c\", action(\"on-click\", \"a\", {}), action(\"on-key\", \"b\", {}))" Null+      `shouldBe` Right+        ( elemJ+            "b"+            [attrJ "class" (String "c"), actionJ "on-click" "a" (object []), actionJ "on-key" "b" (object [])]+            []+            Null+        )++-- Bindings ----------------------------------------------------------------------------++bindingSpec :: Spec+bindingSpec = describe "bindings and closures" $ do+  it "evaluates in declaration order, each seeing the earlier ones" $+    val "@a=1\n@b=$a\n{\"b\": $b}" Null `shouldBe` Right (object ["b" .= (1 :: Int)])++  it "does not let a binding see a later one" $+    val "@a=$b\n@b=1\n$a" Null `shouldSatisfy` isLeftWith "UnboundName"++  it "captures the environment at the point the lambda is created" $+    val "@t=10\n@big=(x) => gt($x, $t)\n@t2=$big(42)\n$t2" Null `shouldBe` Right (Bool True)++  -- Not an accident: a binding's value is inserted only after it is+  -- evaluated, so nothing in the language can recurse.+  it "does not let a lambda call itself by its own binding name" $+    val "@f=(x) => $f($x)\n$f(1)" Null `shouldSatisfy` isLeftWith "UnboundName"++  it "allows kebab-case names" $+    val "@my-var=1\n$my-var" Null `shouldBe` Right (Number 1)++  it "passes a builtin by reference" $+    val "map($ctx.xs, $not)" (object ["xs" .= [True, False]]) `shouldBe` Right (arr [Bool False, Bool True])+  where+    isLeftWith needle = either (\e -> needle `elem` words (map (\c -> if c == '"' then ' ' else c) e)) (const False)++-- Concat --------------------------------------------------------------------------------++concatSpec :: Spec+concatSpec = describe "concat" $ do+  it "joins strings" $ val "\"a\" <> \"b\"" Null `shouldBe` Right (String "ab")+  it "appends arrays" $ val "[1, 2] <> [3]" Null `shouldBe` Right (arr [Number 1, Number 2, Number 3])++  it "merges objects right-biased" $+    val "{\"a\": 1, \"b\": 2} <> {\"b\": 3, \"c\": 4}" Null+      `shouldBe` Right (object ["a" .= (1 :: Int), "b" .= (3 :: Int), "c" .= (4 :: Int)])++  it "rejects mixed types rather than coercing" $+    ("\"a\" <> [1]" `failsWith'` \case ConcatMismatch _ _ -> True; _ -> False) `shouldBe` True++  it "is associative over a chain" $+    val "\"a\" <> \"b\" <> \"c\"" Null `shouldBe` Right (String "abc")++  it "has the natural identity for each type" $ do+    val "\"a\" <> \"\"" Null `shouldBe` Right (String "a")+    val "[1] <> []" Null `shouldBe` Right (arr [Number 1])+    val "{\"a\": 1} <> {}" Null `shouldBe` Right (object ["a" .= (1 :: Int)])+  where+    failsWith' src p = failsWith p src Null++-- Branch ----------------------------------------------------------------------------------++-- | Uniformly lazy, in every position -- decisions.md #3.+branchSpec :: Spec+branchSpec = describe "branch" $ do+  it "selects a value by the first true predicate" $+    val "branch(\"unknown\", eq($ctx.s, \"ready\"), \"ready\", eq($ctx.s, \"err\"), \"error\")" (object ["s" .= ("err" :: Text)])+      `shouldBe` Right (String "error")++  it "falls back when no predicate holds" $+    val "branch(\"unknown\", false, \"a\")" Null `shouldBe` Right (String "unknown")++  it "selects a document in a child position" $+    doc ".div(branch(.p(\"fallback\"), eq($ctx.s, \"ready\"), .p(\"ready\")))" (object ["s" .= ("ready" :: Text)])+      `shouldBe` Right (el "div" [el "p" [textJ (String "ready")]])++  it "does not evaluate the arm it does not select, so its errors never surface" $+    val "branch(\"fallback\", false, $nope.deeply.broken)" Null `shouldBe` Right (String "fallback")++  it "does not evaluate a later predicate once one has matched" $+    val "branch(\"fallback\", true, \"first\", $nope, \"second\")" Null `shouldBe` Right (String "first")++  it "requires its condition to be a boolean" $+    ("branch(\"f\", \"not a bool\", \"a\")" `failsWithT` \case TypeMismatch _ -> True; _ -> False) `shouldBe` True+  where+    failsWithT src p = failsWith p src Null++-- Collections -------------------------------------------------------------------------------++collectionSpec :: Spec+collectionSpec = describe "collections" $ do+  it "maps to repeated children when its function returns documents" $+    doc ".ul(map($ctx.items, (i) => .li($i.name)))" (items ["a", "b"])+      `shouldBe` Right (el "ul" [el "li" [textJ (String "a")], el "li" [textJ (String "b")]])++  -- One map, two uses: the array is the value; splicing is the child rule.+  it "maps to an array when used as a value" $+    val "map($ctx.items, (i) => $i.name)" (items ["a", "b"]) `shouldBe` Right (arr [String "a", String "b"])++  it "splices a mapped array among ordinary siblings" $+    doc ".ul(.li(\"first\"), map($ctx.items, (i) => .li($i.name)), .li(\"last\"))" (items ["a"])+      `shouldBe` Right+        (el "ul" [el "li" [textJ (String "first")], el "li" [textJ (String "a")], el "li" [textJ (String "last")]])++  it "filters" $+    val "filter($ctx.xs, (x) => gt($x, 1))" (object ["xs" .= ([1, 2, 3] :: [Int])])+      `shouldBe` Right (arr [Number 2, Number 3])++  it "scans, keeping the initial accumulator and every step" $+    val "scan($ctx.xs, 0, (a, x) => $x)" (object ["xs" .= ([1, 2] :: [Int])])+      `shouldBe` Right (arr [Number 0, Number 1, Number 2])++  it "folds, keeping only the final accumulator" $+    val "fold($ctx.xs, 0, (a, x) => $x)" (object ["xs" .= ([1, 2] :: [Int])]) `shouldBe` Right (Number 2)++  it "scopes the lambda parameter to its own body" $+    val "@r=map($ctx.xs, (x) => $x)\n$x" (object ["xs" .= ([1] :: [Int])])+      `shouldBe` Left "UnboundName \"x\""++-- Imports ---------------------------------------------------------------------------------------++importSpec :: Spec+importSpec = describe "imports" $ do+  it "renders a complete import" $+    doc "import(\"panel\", {\"name\": \"web\", \"replicas\": 3}).rendered" Null+      `shouldBe` Right (el "section" [el "h2" [textJ (String "web")], el "p" [textJ (Number 3)]])++  it "exposes an expression-rooted library's result" $+    val "import(\"data\", {\"b\": 2}).rendered" Null+      `shouldBe` Right (object ["a" .= (1 :: Int), "b" .= (2 :: Int)])++  it "exposes the library's top-level bindings as .vals" $+    val "import(\"data\", {\"b\": 2}).vals.a" Null `shouldBe` Right (Number 1)++  -- decisions.md #10: ctx(path) reads the importing program's own context,+  -- where the import is written -- the same value @$ctx.path@ would give.+  it "substitutes a ctx(path) parameter from the importing context" $+    doc+      "import(\"panel\", {name: ctx(n), replicas: ctx(spec.replicas)}).rendered"+      (object ["n" .= ("web" :: Text), "spec" .= object ["replicas" .= (3 :: Int)]])+      `shouldBe` Right (el "section" [el "h2" [textJ (String "web")], el "p" [textJ (Number 3)]])++  -- ... and omission, not ctx(...), is what leaves a parameter for later.+  it "saturates an omitted parameter by calling the import" $+    doc "@p=import(\"panel\", {\"name\": \"web\"})\n$p({\"replicas\": 3}).rendered" Null+      `shouldBe` Right (el "section" [el "h2" [textJ (String "web")], el "p" [textJ (Number 3)]])++  it "accumulates parameters across calls, one at a time" $+    doc "@p=import(\"panel\", {})\n@half=$p({\"name\": \"web\"})\n$half({\"replicas\": 2}).rendered" Null+      `shouldBe` Right (el "section" [el "h2" [textJ (String "web")], el "p" [textJ (Number 2)]])++  it "lets a later call override an earlier parameter" $+    doc "@p=import(\"panel\", {name: ctx(n), \"replicas\": 3})\n$p({\"name\": \"web\"}).rendered" (object ["n" .= ("stale" :: Text)])+      `shouldBe` Right (el "section" [el "h2" [textJ (String "web")], el "p" [textJ (Number 3)]])++  -- The point of running a library on field access rather than where the+  -- import is written: one wired-up import, reused per iteration.+  it "reuses one import with different parameters" $+    val "@p=import(\"data\", {})\nmap([1, 2], (b) => $p({\"b\": $b}).rendered.b)" Null+      `shouldBe` Right (Array (V.fromList [Number 1, Number 2]))++  it "reports a parameter nobody supplied as the library's own missing path" $+    run "import(\"panel\", {\"name\": \"web\"}).rendered" Null+      `shouldBe` Left (show (InLibrary "panel" (PathNotFound ["ctx", "replicas"])))++  it "reports a ctx(path) the importing context lacks, at the import" $+    run "import(\"panel\", {name: ctx(nope), \"replicas\": 3}).rendered" (object ["name" .= ("web" :: Text)])+      `shouldBe` Left (show (PathNotFound ["ctx", "nope"]))++  it "refuses to use an import that has not been run" $+    (".div(\"data-x\": import(\"data\", {\"b\": 1}))" `failsWithN` \case TypeMismatch _ -> True; _ -> False)+      `shouldBe` True++  it "refuses to saturate an import with anything but an object" $+    ("@p=import(\"panel\", {})\n$p(3).rendered" `failsWithN` \case TypeMismatch _ -> True; _ -> False)+      `shouldBe` True++  it "detects an import cycle instead of looping" $+    ("import(\"loopy\", {}).rendered" `failsWithN` \case InLibrary _ (ImportCycle _) -> True; _ -> False) `shouldBe` True++  it "reports an unknown library" $+    ("import(\"nope\", {}).rendered" `failsWithN` \case UnknownLibrary _ -> True; _ -> False) `shouldBe` True++  it "passes a document into a library as an ordinary parameter" $+    val "import(\"data\", {\"b\": 2}).vals.a" Null `shouldBe` Right (Number 1)+  where+    failsWithN src p = failsWith p src Null++-- Action adaptation ------------------------------------------------------------------------------++adaptSpec :: Spec+adaptSpec = describe "adapt-actions" $ do+  it "prefixes every action key in the subtree" $+    doc "adapt-actions(import(\"two-actions\", {}).rendered, prefix(\"user:\"))" Null+      `shouldBe` Right+        ( el+            "div"+            [ elemJ "b" [actionJ "on-click" "user:save" (object [])] [] Null+            , elemJ "b" [actionJ "on-click" "user:delete" (object [])] [] Null+            ]+        )++  it "composes, outermost prefix last" $+    val "cardinality({})" Null `shouldBe` Right (Number 0)++  it "composes two adaptations as b:a:key" $+    doc "adapt-actions(adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, prefix(\"a:\")), prefix(\"b:\"))" Null+      `shouldBe` Right+        ( elemJ+            "button"+            [actionJ "on-click" "b:a:deploy" (object ["n" .= ("w" :: Text)])]+            [textJ (String "go: w")]+            Null+        )++  it "leaves keys alone under the identity adaptation" $+    doc "adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, identity)" Null+      `shouldBe` Right+        ( elemJ+            "button"+            [actionJ "on-click" "deploy" (object ["n" .= ("w" :: Text)])]+            [textJ (String "go: w")]+            Null+        )++  -- The closure sees the already-prefixed action and may change only the+  -- event type and payload; a key it returns is ignored, which is what keeps+  -- the vocabulary statically knowable.+  it "lets the closure rewrite the event type and payload but not the key" $+    doc "adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, prefix(\"x:\"), (a) => {\"eventType\": \"on-tap\", \"key\": \"ignored\", \"payload\": {\"orig\": $a.key}})" Null+      `shouldBe` Right+        ( elemJ+            "button"+            [actionJ "on-tap" "x:deploy" (object ["orig" .= ("x:deploy" :: Text)])]+            [textJ (String "go: w")]+            Null+        )++  it "reaches actions inside a nested import" $+    doc "adapt-actions(import(\"wrapper\", {}).rendered, prefix(\"w:\"))" Null+      `shouldBe` Right+        ( el+            "div"+            [ elemJ+                "button"+                [actionJ "on-click" "w:deploy" (object ["n" .= ("inner" :: Text)])]+                [textJ (String "go: inner")]+                Null+            ]+        )++  it "queues on an import that has not run and applies to its result" $+    doc "@p=import(\"button\", {})\n@a=adapt-actions($p, prefix(\"q:\"))\n$a({\"name\": \"w\"}).rendered" Null+      `shouldBe` Right+        ( elemJ+            "button"+            [actionJ "on-click" "q:deploy" (object ["n" .= ("w" :: Text)])]+            [textJ (String "go: w")]+            Null+        )++  it "leaves ordinary attributes and the value slot untouched" $+    doc "adapt-actions(.b(class: \"c\", value(1), action(\"on-click\", \"k\", {})), prefix(\"p:\"))" Null+      `shouldBe` Right+        (elemJ "b" [attrJ "class" (String "c"), actionJ "on-click" "p:k" (object [])] [] (Number 1))++  it "passes through a value that has no actions at all" $+    val "adapt-actions(\"plain\", prefix(\"p:\"))" Null `shouldBe` Right (String "plain")++-- Errors ----------------------------------------------------------------------------------------------++errorSpec :: Spec+errorSpec = describe "errors" $ do+  it "reports an unbound name" $+    (failsWith (\case UnboundName _ -> True; _ -> False) "$nope" Null) `shouldBe` True++  it "reports a missing field with the path as written" $+    (failsWith (\case PathNotFound ["ctx", "a", "b"] -> True; _ -> False) "$ctx.a.b" (object ["a" .= object []]) )+      `shouldBe` True++  it "refuses a function used where a value is expected" $+    (failsWith (\case TypeMismatch _ -> True; _ -> False) "@f=(x) => $x\n[$f, 1]" Null) `shouldBe` True++  it "accepts the same function once it is called" $+    val "@f=(x) => $x\n[$f(1), 2]" Null `shouldBe` Right (arr [Number 1, Number 2])++  it "refuses a document used where a plain value is expected" $+    (failsWith (\case TypeMismatch _ -> True; _ -> False) ".div(class: .p(\"x\"))" Null) `shouldBe` True++  it "reports a closure applied to the wrong number of arguments" $+    (failsWith (\case TypeMismatch _ -> True; _ -> False) "@f=(x, y) => $x\n$f(1)" Null) `shouldBe` True++  it "reports a non-array given to map" $+    (failsWith (\case TypeMismatch _ -> True; _ -> False) "map(1, (x) => $x)" Null) `shouldBe` True++-- Types (v4-types, roadmap Phases 11-13) ---------------------------------------------------------------++-- | 'runProgram' over 'libs', for a given mode -- what a host actually+-- serializes, rather than the internal 'Output'.+runMode :: Mode -> Text -> Value -> Either String Value+runMode mode src ctx = case parseProgram src of+  Left e -> Left ("parse error: " <> show e)+  Right prog -> either (Left . show) Right (runProgram mode libs ctx prog)++typeSpec :: Spec+typeSpec = describe "types" $ do+  it "erasure invariant (\\S8): a concrete-mode run is byte-identical to the same program with its annotation deleted" $+    runMode Concrete "@d : string = \"x\"\n$d" Null+      `shouldBe` runMode Concrete "@d = \"x\"\n$d" Null++  it "an annotated binding emits a has-type constraint carrying the erased $type tag (\\S7)" $+    case runMode Symbolic "type Deployment = { replicas : number }\n@d : Deployment = {\"replicas\": 3}\n$d" Null of+      Right (Object o) ->+        KeyMap.lookup "constraints" o+          `shouldBe` Just+            ( Array+                ( V.fromList+                    [ object+                        [ "name" .= ("has-type" :: Text)+                        , "arguments"+                            .= [ object ["replicas" .= (3 :: Int)]+                               , object ["$type" .= ("root:Deployment" :: Text)]+                               ]+                        ]+                    ]+                )+            )+      other -> expectationFailure ("expected a symbolic envelope object, got " <> show other)++  it "the \"types\" table carries the referenced type's own definition, closed over its fields" $+    case runMode Symbolic "type Deployment = { replicas : number }\n@d : Deployment = {\"replicas\": 3}\n$d" Null of+      Right (Object o) ->+        KeyMap.lookup "types" o+          `shouldBe` Just+            ( Array+                ( V.fromList+                    [ object+                        [ "id" .= ("root:Deployment" :: Text)+                        , "definition"+                            .= object+                              [ "kind" .= ("record" :: Text)+                              , "fields" .= [object ["name" .= ("replicas" :: Text), "type" .= object ["kind" .= ("prim" :: Text), "name" .= ("number" :: Text)]]]+                              ]+                        ]+                    ]+                )+            )+      other -> expectationFailure ("expected a symbolic envelope object, got " <> show other)++  it "a !type-constraint appears in \"type-constraints\", resolved, and never in \"constraints\"" $+    case runMode Symbolic "type Json = string\n!type-constraint(\"has-default\", %Json)\ntrue" Null of+      Right (Object o) -> do+        KeyMap.lookup "type-constraints" o+          `shouldBe` Just (Array (V.fromList [object ["name" .= ("has-default" :: Text), "arguments" .= [object ["$type" .= ("root:Json" :: Text)]]]]))+        KeyMap.lookup "constraints" o `shouldBe` Just (Array V.empty)+      other -> expectationFailure ("expected a symbolic envelope object, got " <> show other)++  it "a symbol-free, type-free program's envelope carries empty \"types\" and \"type-constraints\" (\\S8: a v3 consumer sees nothing new)" $+    case runMode Symbolic "1" Null of+      Right (Object o) -> do+        KeyMap.lookup "types" o `shouldBe` Just (Array V.empty)+        KeyMap.lookup "type-constraints" o `shouldBe` Just (Array V.empty)+      other -> expectationFailure ("expected a symbolic envelope object, got " <> show other)++  it "an annotation whose type is still partial is a static PartialType error (\\S4), not an evaluation one" $+    let libsHere = Map.fromList [("message", either (\e -> error (show e)) id (parseProgram "type Envelope = { payload : %ctx.payload }\ntrue"))]+        p = either (\e -> error (show e)) id (parseProgram "@msg=import(\"message\", {})\n@m : $msg.types.Envelope = 1\ntrue")+     in case runProgram Concrete libsHere Null p of+          Left (TypeErr (PartialType _ _)) -> pure ()+          other -> expectationFailure ("expected a PartialType error, got " <> show other)

@@ -0,0 +1,199 @@+-- | Round-trip and shape checks for the normative Node JSON representation+-- specified in @../specs/node-json.md@. The round-trip property is the one+-- that matters: it is what lets an independent implementation decode what+-- this one encodes, so it is checked over trees covering all three node+-- constructors, both attribute kinds, non-empty annotations, and scalar+-- values of every JSON type.+module Tramaj.NodeJsonSpec (spec) where++import Data.Aeson (ToJSON, Value (..), object, (.=))+import qualified Data.Map.Strict as Map+import Test.Hspec+import Tramaj.Node++spec :: Spec+spec = describe "Tramaj.Node JSON representation" $ do+  roundTripSpec+  shapeSpec+  rejectionSpec+  mapActionsSpec++-- | Every sample below must survive @nodeFromJson . nodeToJson@ unchanged.+samples :: [(String, Node)]+samples =+  [ ("text holding a string", NText (String "hello") noAnnotations)+  , ("text holding a number", NText (Number 3) noAnnotations)+  , ("text holding null", NText Null noAnnotations)+  , ("text holding a boolean", NText (Bool True) noAnnotations)+  , ("text holding an object", NText (object ["a" .= (1 :: Int)]) noAnnotations)+  , ("empty element", NElement "div" [] Null [] noAnnotations)+  , ("element with an ordinary attribute", NElement "div" [NAttr "class" (String "panel")] Null [] noAnnotations)+  ,+    ( "element with several actions and attributes interleaved"+    , NElement+        "button"+        [ NAttr "class" (String "primary")+        , NAction "on-click" "save" (object ["id" .= (1 :: Int)])+        , NAttr "data-n" (Number 2)+        , NAction "on-double-click" "open" Null+        ]+        Null+        [NText (String "Save") noAnnotations]+        noAnnotations+    )+  , ("element with a value slot", NElement "Replicas" [] (Number 3) [] noAnnotations)+  , ("fragment", NFragment [NText (String "one") noAnnotations, NText (String "two") noAnnotations] noAnnotations)+  , ("empty fragment", NFragment [] noAnnotations)+  ,+    ( "annotations at every level, including ones the core does not understand"+    , NElement+        "section"+        [NAttr "id" (String "x")]+        Null+        [NFragment [NText (String "deep") (Map.fromList [("origin", String "lib")])] (Map.fromList [("flattenable", Bool True)])]+        (Map.fromList [("type", String "Section"), ("domain", object ["min" .= (1 :: Int)])])+    )+  , ("repeated attribute names are preserved, not deduplicated", NElement "div" [NAttr "class" (String "a"), NAttr "class" (String "b")] Null [] noAnnotations)+  ]++roundTripSpec :: Spec+roundTripSpec = describe "round-trips through the normative representation" $+  mapM_ (\(name, n) -> it name (nodeFromJson (nodeToJson n) `shouldBe` Right n)) samples++-- | The exact bytes matter as much as the round-trip: another implementation+-- reads these keys, so a rename would be a silent wire-format break that a+-- round-trip test alone would not catch.+shapeSpec :: Spec+shapeSpec = describe "encodes the shape specs/node-json.md documents" $ do+  it "a text node carries its value unconverted, plus annotations" $+    nodeToJson (NText (Number 3) noAnnotations)+      `shouldBe` object ["type" .= ("text" :: String), "value" .= (3 :: Int), "annotations" .= object []]++  it "an element always emits tag, attributes, value, children and annotations" $+    nodeToJson (NElement "p" [] Null [] noAnnotations)+      `shouldBe` object+        [ "type" .= ("element" :: String)+        , "tag" .= ("p" :: String)+        , "attributes" .= ([] :: [Value])+        , "value" .= Null+        , "children" .= ([] :: [Value])+        , "annotations" .= object []+        ]++  it "attributes and actions are discriminated by \"kind\" in one ordered list" $+    nodeToJson (NElement "b" [NAttr "class" (String "c"), NAction "on-click" "save" Null] Null [] noAnnotations)+      `shouldBe` object+        [ "type" .= ("element" :: String)+        , "tag" .= ("b" :: String)+        , "attributes"+            .= [ object ["kind" .= ("attribute" :: String), "name" .= ("class" :: String), "value" .= ("c" :: String)]+               , object ["kind" .= ("action" :: String), "event" .= ("on-click" :: String), "key" .= ("save" :: String), "payload" .= Null]+               ]+        , "value" .= Null+        , "children" .= ([] :: [Value])+        , "annotations" .= object []+        ]++  it "a fragment emits no tag, attributes or value" $+    nodeToJson (NFragment [] noAnnotations)+      `shouldBe` object ["type" .= ("fragment" :: String), "children" .= ([] :: [Value]), "annotations" .= object []]++-- | @specs/node-json.md@, "Decoding": a decoder must reject rather than+-- default, so that a malformed document is reported where it is read.+-- Malformed documents are built as 'Value's directly rather than parsed from+-- JSON text, so each one differs from a well-formed node in exactly the one+-- way its name describes.+rejectionSpec :: Spec+rejectionSpec = describe "rejects malformed documents rather than defaulting" $ do+  let rejects name js = it name (nodeFromJson js `shouldSatisfy` either (const True) (const False))++  rejects "a node with no type" $+    object ["value" .= (1 :: Int), "annotations" .= object []]+  rejects "an unknown node type" $+    object ["type" .= ("comment" :: String), "annotations" .= object []]+  rejects "a text node with no value" $+    object ["type" .= ("text" :: String), "annotations" .= object []]+  rejects "a node with no annotations" $+    object ["type" .= ("text" :: String), "value" .= (1 :: Int)]+  rejects "an element with no value slot" $+    object+      [ "type" .= ("element" :: String)+      , "tag" .= ("p" :: String)+      , "attributes" .= ([] :: [Value])+      , "children" .= ([] :: [Value])+      , "annotations" .= object []+      ]+  rejects "an element with a non-string tag" $+    element (Number 1) ([] :: [Value]) ([] :: [Value])+  rejects "an element whose children are not an array" $+    element (String "p") ([] :: [Value]) (object [])+  rejects "an element whose attributes are not an array" $+    element (String "p") (object []) ([] :: [Value])+  rejects "annotations that are not an object" $+    object ["type" .= ("fragment" :: String), "children" .= ([] :: [Value]), "annotations" .= ([] :: [Value])]+  rejects "an attribute with no kind" $+    element (String "p") [object ["name" .= ("a" :: String), "value" .= (1 :: Int)]] ([] :: [Value])+  rejects "an unknown attribute kind" $+    element (String "p") [object ["kind" .= ("listener" :: String)]] ([] :: [Value])+  rejects "an action with no key" $+    element (String "p") [object ["kind" .= ("action" :: String), "event" .= ("e" :: String), "payload" .= Null]] ([] :: [Value])+  rejects "an attribute with a non-string name" $+    element (String "p") [object ["kind" .= ("attribute" :: String), "name" .= (1 :: Int), "value" .= Null]] ([] :: [Value])+  rejects "a malformed node nested deep in a child" $+    object+      [ "type" .= ("fragment" :: String)+      , "children" .= [object ["type" .= ("text" :: String)]]+      , "annotations" .= object []+      ]+  rejects "a bare scalar where a node was expected" $ Number 42+  rejects "an attribute that is not an object" $+    element (String "p") [String "class"] ([] :: [Value])+  where+    -- | A well-formed element apart from whichever of its three variable+    -- parts the caller deliberately breaks.+    element :: (ToJSON a, ToJSON b) => Value -> a -> b -> Value+    element tag attrs children =+      object+        [ "type" .= ("element" :: String)+        , "tag" .= tag+        , "attributes" .= attrs+        , "value" .= Null+        , "children" .= children+        , "annotations" .= object []+        ]++-- | @adapt-actions@ leans on this: it must reach actions at every depth and+-- leave everything else -- annotations especially -- exactly as it found it.+mapActionsSpec :: Spec+mapActionsSpec = describe "mapActions" $ do+  let prefixKey p (NAction e k pl) = NAction e (p <> k) pl+      prefixKey _ a = a+      prefix p = mapActions (\e k pl -> Right (prefixKey p (NAction e k pl))) :: Node -> Either () Node++  it "rewrites actions nested under children and fragments" $+    prefix "ns:"+      ( NElement+          "div"+          []+          Null+          [NFragment [NElement "b" [NAction "on-click" "save" Null] Null [] noAnnotations] noAnnotations]+          noAnnotations+      )+      `shouldBe` Right+        ( NElement+            "div"+            []+            Null+            [NFragment [NElement "b" [NAction "on-click" "ns:save" Null] Null [] noAnnotations] noAnnotations]+            noAnnotations+        )++  it "leaves ordinary attributes, value slots and annotations untouched" $+    let anns = Map.fromList [("origin", String "lib")]+        n = NElement "div" [NAttr "class" (String "c"), NAction "on-click" "save" Null] (Number 1) [] anns+     in prefix "ns:" n+          `shouldBe` Right (NElement "div" [NAttr "class" (String "c"), NAction "on-click" "ns:save" Null] (Number 1) [] anns)++  it "propagates a failing rewrite instead of dropping it" $+    mapActions (\_ _ _ -> Left "boom") (NElement "b" [NAction "on-click" "save" Null] Null [] noAnnotations)+      `shouldBe` (Left "boom" :: Either String Node)

@@ -0,0 +1,375 @@+-- | Grammar checks: what the surface accepts, what it rejects, and what it+-- desugars into.+--+-- The desugaring assertions matter more than they look. Every one of them+-- pins a surface convenience to the core constructors it lowers to, which is+-- the property the language design rests on: the surface may grow, the+-- semantic AST should not. A test here failing means a convenience quietly+-- became a semantic construct.+module Tramaj.ParserSpec (spec) where++import Data.Either (isLeft, isRight)+import Data.Text (Text)+import Test.Hspec+import Tramaj.Ast+import Tramaj.Parser++spec :: Spec+spec = do+  acceptanceSpec+  rejectionSpec+  commentSpec+  desugaringSpec+  programKindSpec+  typeExprSpec++-- | Parses to /something/; what exactly is 'desugaringSpec''s business.+accepts :: String -> Text -> Spec+accepts name src = it name (parseProgram src `shouldSatisfy` isRight)++rejects :: String -> Text -> Spec+rejects name src = it name (parseProgram src `shouldSatisfy` isLeft)++acceptanceSpec :: Spec+acceptanceSpec = describe "accepts" $ do+  accepts "a plain nested element tree" ".div(.p(\"Hello\"))"+  accepts "a fragment as the root" ".(.p(\"a\"), .p(\"b\"))"+  accepts "an empty fragment" ".()"+  accepts "an element with no arguments at all" ".hr()"+  accepts "kebab-case tags and binding names" "@my-var=1\n.my-tag(\"x\")"+  accepts "a quoted attribute key alongside a bare one" ".div(class: \"a\", \"data-id\": 1)"+  accepts "several actions on one element" ".b(action(\"on-click\", \"a\", {}), action(\"on-key\", \"b\", {}))"+  accepts "an element value slot" ".Replicas(value(3))"+  accepts "a bare special form as a child" ".div(fold($ctx.nums, 0, (acc, n) => $acc))"+  accepts "an import as a child" ".div(import(\"lib\", {}).rendered)"+  accepts "a ctx(...) import parameter" "@p=import(\"lib\", {name: ctx(spec.name)})\n$p({}).rendered"+  accepts "adapt-actions without a closure" "adapt-actions($x, prefix(\"ns:\"))"+  accepts "adapt-actions with a closure" "adapt-actions($x, prefix(\"ns:\"), (a) => $a)"+  accepts "the identity adaptation" "adapt-actions($x, identity)"+  accepts "a call on a dotted path" "$lib.vals.fn(1)"+  accepts "concat chained several times" "\"a\" <> \"b\" <> \"c\""+  accepts "a parenthesized expression" "(1)"+  accepts "an expression-rooted program" "@n=1\n{\"n\": $n}"+  accepts "a trailing comma in an element's arguments" ".div(\"a\", \"b\",)"+  accepts "a lambda with no parameters" "() => 1"++  -- The v1 regression this replaces: a '.' beginning the next line is a new+  -- element, not a field access on the call that just closed.+  accepts+    "a '.' starting the next line rather than continuing a field access"+    "@x=cardinality($ctx.items)\n.div(\"`$x`\")"++rejectionSpec :: Spec+rejectionSpec = describe "rejects" $ do+  rejects "an attribute after a child" ".div(.p(\"hi\"), class: \"a\")"+  rejects "an action after a child" ".div(.p(\"hi\"), action(\"on-click\", \"a\", {}))"+  rejects "a value slot after a child" ".div(.p(\"hi\"), value(1))"+  rejects "more than one value slot" ".div(value(1), value(2))"++  -- Every static position is static because the grammar refuses anything+  -- else there -- not because evaluation checks it later.+  rejects "an import name that is computed" "@l=import($ctx.name, {})\n.div($l.rendered)"+  rejects "an import name that is interpolated" "@l=import(\"a`$x`\", {})\n.div($l.rendered)"+  rejects "an action key that is computed" ".b(action(\"on-click\", $ctx.key, {}))"+  rejects "an action event that is computed" ".b(action($ctx.evt, \"save\", {}))"+  rejects "an adaptation prefix that is computed" "adapt-actions($x, prefix($ctx.ns))"+  rejects "an adaptation that is an arbitrary function" "adapt-actions($x, (a) => $a)"+  rejects "an unknown adaptation" "adapt-actions($x, replace(\"a\", \"b\"))"++  -- A malformed special form must fail here, not fall through to a+  -- meaningless Call that only fails much later.+  rejects "a malformed import" "import(\"lib\")"+  rejects "a malformed map" "map($xs)"+  rejects "import parameters that are not a parameter list" "import(\"lib\", $ctx)"++  rejects "an unknown escape sequence" "\"a\\qb\""+  rejects "an unterminated string" "\"abc"+  rejects "trailing input after the root" ".div() .span()"++  -- A hyphen is a name character only between two others, which is what+  -- leaves @--@ free to start a comment right after a name.+  rejects "a binding name ending in a hyphen" "@a-=1\n$a"+  rejects "a tag ending in a hyphen" ".div-()"++-- | Comments: @--@ to the end of the line, single-line only.+--+-- The load-bearing assertion is 'leavesNoTrace' -- a commented program and+-- the same program with the comments deleted must parse to the /same/ AST.+-- Anything weaker would pass while comments quietly became a node, or shifted+-- what the parser saw around them.+commentSpec :: Spec+commentSpec = describe "comments" $ do+  accepts "a whole-line comment above the bindings" "-- a heading\n@n=1\n.p($n)"+  accepts "a comment trailing a binding" "@n=1 -- how many\n.p($n)"+  accepts "a comment inside an element's arguments" ".div(\n  class: \"a\", -- the class\n  .p(\"hi\")\n)"+  accepts "a comment between two children" ".div(\n  .p(\"a\"),\n  -- and then\n  .p(\"b\")\n)"+  accepts "a comment as the last line, with no newline after it" ".p(\"hi\")\n-- done"+  accepts "a comment directly after the root, on the same line" ".p(\"hi\") -- done"+  accepts "a file that is comments and one expression" "-- one\n-- two\n1"+  accepts "an empty comment" ".p(\"hi\") --"+  accepts "a second -- inside a comment, which does not nest or close it" "1 -- a -- b"++  leavesNoTrace+    "a comment on its own line, and one trailing a binding"+    "-- the count\n@n=cardinality($ctx.items) -- how many\n.p(\"`$n`\")"+    "@n=cardinality($ctx.items)\n.p(\"`$n`\")"++  leavesNoTrace+    "comments interleaved with an element's arguments"+    ".div(class: \"a\", -- attrs first\n  .p(\"hi\") -- then children\n)"+    ".div(class: \"a\", .p(\"hi\"))"++  -- A comment is whitespace, and whitespace before a '.' is exactly what+  -- separates a new element from a field access on the call that just+  -- closed. So the v1 regression stays fixed with a comment in between.+  leavesNoTrace+    "a comment between a closing ')' and a '.' beginning the next line"+    "@x=cardinality($ctx.items) -- a count\n.div(\"`$x`\")"+    "@x=cardinality($ctx.items)\n.div(\"`$x`\")"++  it "leaves `--` inside a string literal as ordinary text" $+    parseExpr "\"a -- b\"" `shouldBe` Right (StringLit "a -- b")++  it "leaves `--` inside a static string as ordinary text" $+    parseExpr "adapt-actions($x, prefix(\"a--b:\"))"+      `shouldBe` Right (AdaptActions (Path "x" []) (Prefix "a--b:") Nothing)++  -- The name stops at the hyphen pair rather than swallowing it, so this is+  -- a read of `x` followed by a comment -- not a read of a name `x--`.+  it "ends a name at a comment written directly against it" $+    parseExpr "$x-- note" `shouldBe` Right (Path "x" [])++  it "still takes a hyphen between two name characters" $+    parseExpr "$my-var-2" `shouldBe` Right (Path "my-var-2" [])+  where+    leavesNoTrace :: String -> Text -> Text -> Spec+    leavesNoTrace name commented plain =+      it ("leave no trace in the AST: " <> name) $+        parseProgram commented `shouldBe` parseProgram plain++-- | Each case states the desugaring in full: surface on the left, core AST on+-- the right, with nothing in between.+desugaringSpec :: Spec+desugaringSpec = describe "desugars" $ do+  let parsesTo name src expected = it name (parseExpr src `shouldBe` Right expected)++  parsesTo "a plain string to a single literal" "\"hello\"" (StringLit "hello")++  parsesTo+    "escape sequences into the characters they denote, leaving one literal"+    "\"a\\nb\\tc\\\\d\\\"e\""+    (StringLit "a\nb\tc\\d\"e")++  parsesTo "a braced unicode escape" "\"\\u{1F600}\"" (StringLit "\128512")++  parsesTo+    "interpolation into concat over the str builtin"+    "\"n: `$x`!\""+    (Concat (Concat (StringLit "n: ") (Call (Path "str" []) [Path "x" []])) (StringLit "!"))++  parsesTo "an empty string" "\"\"" (StringLit "")++  parsesTo+    "object shorthand into an explicit field reading the same name"+    "{foo, bar: 1}"+    (ObjectLit [("foo", Path "foo" []), ("bar", NumberLit 1)])++  parsesTo+    "a multi-armed branch into nested Branch, fallback innermost"+    "branch(0, $a, 1, $b, 2)"+    (Branch (Path "a" []) (NumberLit 1) (Branch (Path "b" []) (NumberLit 2) (NumberLit 0)))++  parsesTo+    "concat as a left-associative chain"+    "$a <> $b <> $c"+    (Concat (Concat (Path "a" []) (Path "b" [])) (Path "c" []))++  parsesTo+    "a fragment into Fragment, with no wrapper element"+    ".(.p(\"a\"))"+    (Fragment [Element "p" [] NullLit [StringLit "a"]])++  parsesTo+    "an element's arguments into attributes, value slot and children"+    ".div(class: \"a\", action(\"on-click\", \"save\", 1), value(2), \"kid\")"+    ( Element+        "div"+        [Attr "class" (StringLit "a"), ActionAttr "on-click" "save" (NumberLit 1)]+        (NumberLit 2)+        [StringLit "kid"]+    )++  parsesTo+    "an absent value slot into NullLit"+    ".div()"+    (Element "div" [] NullLit [])++  parsesTo+    "import parameters into supplied values and declared context holes"+    "import(\"dep\", {\"name\": \"web\", \"replicas\": ctx(spec.replicas)})"+    (Import "dep" [("name", PExpr (StringLit "web")), ("replicas", PFromContext ["spec", "replicas"])])++  parsesTo+    "import parameter shorthand into a supplied value, not a context hole"+    "import(\"dep\", {name})"+    (Import "dep" [("name", PExpr (Path "name" []))])++  parsesTo+    "an omitted adaptation closure into Nothing"+    "adapt-actions($x, prefix(\"ns:\"))"+    (AdaptActions (Path "x" []) (Prefix "ns:") Nothing)++  parsesTo "a dotted path into one Path, not nested field accesses" "$a.b.c" (Path "a" ["b", "c"])++  parsesTo+    "a field access on a call's result into FieldAccess"+    "$f(1).rendered"+    (FieldAccess (Call (Path "f" []) [NumberLit 1]) ["rendered"])++  parsesTo "the $ prefix on a call as optional" "cardinality($x)" (Call (Path "cardinality" []) [Path "x" []])+  parsesTo "the $ prefix on a call as meaning the same thing" "$cardinality($x)" (Call (Path "cardinality" []) [Path "x" []])++  it "binding lines into nested Lets, in declaration order" $+    parseProgram "@a=1\n@b=$a\n.p($b)"+      `shouldBe` Right+        ( DocumentProgram+            (Let "a" (NumberLit 1) (Let "b" (Path "a" []) (Element "p" [] NullLit [Path "b" []])))+        )++-- | Which kind of program it is follows from the root's own form; there is no+-- mode to declare.+programKindSpec :: Spec+programKindSpec = describe "program kind" $ do+  let isDocument (Right (DocumentProgram _)) = True+      isDocument _ = False+      isExpression (Right (ExpressionProgram _)) = True+      isExpression _ = False++  it "an element root is a document program" $+    parseProgram ".div()" `shouldSatisfy` isDocument+  it "a fragment root is a document program" $+    parseProgram ".()" `shouldSatisfy` isDocument+  it "an object root is an expression program" $+    parseProgram "{\"a\": 1}" `shouldSatisfy` isExpression+  it "bindings do not change the kind" $+    parseProgram "@a=.div()\n{\"a\": 1}" `shouldSatisfy` isExpression++-- | @type Name = TypeExpr@ (v4-types \S1.1, roadmap Phase 8: parse only). One+-- case per 'TypeExpr' constructor, each pinning the surface to the exact core+-- shape it parses to -- the same discipline 'desugaringSpec' applies to the+-- value grammar.+typeExprSpec :: Spec+typeExprSpec = describe "type declarations" $ do+  let declares name src expected = it name (parseProgram src `shouldBe` Right expected)++  declares+    "a record declaration"+    "type Point = { x : number, y : number }\ntrue"+    (ExpressionProgram (TypeDecl "Point" (TRecord [("x", TPrim "number"), ("y", TPrim "number")]) (BoolLit True)))++  declares+    "a union declaration with payload-carrying and nullary arms"+    "type Shape = | Circle { r : number } | Dev\ntrue"+    ( ExpressionProgram+        ( TypeDecl+            "Shape"+            (TUnion [("Circle", Just (TRecord [("r", TPrim "number")])), ("Dev", Nothing)])+            (BoolLit True)+        )+    )++  declares+    "a pure-enum union, all arms nullary, immediately followed by a bare keyword root"+    "type Env = | Dev | Staging | Prod\ntrue"+    (ExpressionProgram (TypeDecl "Env" (TUnion [("Dev", Nothing), ("Staging", Nothing), ("Prod", Nothing)]) (BoolLit True)))++  declares+    "an array declaration"+    "type Items = [ string ]\ntrue"+    (ExpressionProgram (TypeDecl "Items" (TArray (TPrim "string")) (BoolLit True)))++  declares+    "a newtype over a primitive"+    "type UserId = string\ntrue"+    (ExpressionProgram (TypeDecl "UserId" (TPrim "string") (BoolLit True)))++  declares+    "a self-recursive declaration, compared nominally rather than expanded"+    "type Tree = | Leaf | Node { l : Tree, r : Tree }\ntrue"+    ( ExpressionProgram+        ( TypeDecl+            "Tree"+            (TUnion [("Leaf", Nothing), ("Node", Just (TRecord [("l", TName "Tree"), ("r", TName "Tree")]))])+            (BoolLit True)+        )+    )++  declares+    "a context type hole in a record field"+    "type Message = { to : string, payload : %ctx.payload }\ntrue"+    (ExpressionProgram (TypeDecl "Message" (TRecord [("to", TPrim "string"), ("payload", TVar ["payload"])]) (BoolLit True)))++  declares+    "a library-qualified type reference"+    "type Big = [ $lib.types.Item ]\ntrue"+    (ExpressionProgram (TypeDecl "Big" (TArray (TLibRef "lib" "Item")) (BoolLit True)))++  it "does not truncate .vals across an intervening type declaration" $+    parseProgram "@a=1\ntype T = string\n@b=2\n.p(\"x\")"+      `shouldBe` Right+        ( DocumentProgram+            ( Let+                "a"+                (NumberLit 1)+                (TypeDecl "T" (TPrim "string") (Let "b" (NumberLit 2) (Element "p" [] NullLit [StringLit "x"])))+            )+        )++  -- roadmap Phase 10: type parameters through imports.+  declares+    "a %-marked import parameter supplying a bare type name"+    "@msg=import(\"message\", {payload: %Json})\ntrue"+    (ExpressionProgram (Let "msg" (Import "message" [("payload", PType (TName "Json"))]) (BoolLit True)))++  declares+    "a %-marked import parameter forwarding a type hole"+    "@in=import(\"inner\", {payload: %ctx.payload})\ntrue"+    (ExpressionProgram (Let "in" (Import "inner" [("payload", PType (TVar ["payload"]))]) (BoolLit True)))++  declares+    "a %-marked import parameter supplying a library-qualified type"+    "@msg=import(\"message\", {payload: %$json.types.Value})\ntrue"+    (ExpressionProgram (Let "msg" (Import "message" [("payload", PType (TLibRef "json" "Value"))]) (BoolLit True)))++  -- roadmap Phase 11: annotated bindings.+  declares+    "an annotated binding desugars to nothing at parse time -- it stays a TypeAnnotate"+    "@d : Deployment = ?(\"d\")\ntrue"+    (ExpressionProgram (TypeAnnotate "d" (TName "Deployment") (Alloc 0 (StringLit "d")) (BoolLit True)))++  declares+    "an annotation naming a library-qualified type"+    "@m : $msg.types.Envelope = 1\ntrue"+    (ExpressionProgram (TypeAnnotate "m" (TLibRef "msg" "Envelope") (NumberLit 1) (BoolLit True)))++  -- roadmap Phase 12: !type-constraint.+  declares+    "a !type-constraint with one type argument"+    "!type-constraint(\"has-default\", %ctx.payload)\ntrue"+    (ExpressionProgram (TypeEmit "has-default" [TCType (TVar ["payload"])] (BoolLit True)))++  declares+    "a !type-constraint mixing a type argument and scalar arguments"+    "!type-constraint(\"coercible-to\", %ctx.payload, %Json, \"lossy\")\ntrue"+    ( ExpressionProgram+        (TypeEmit "coercible-to" [TCType (TVar ["payload"]), TCType (TName "Json"), TCScalarStr "lossy"] (BoolLit True))+    )++  declares+    "a zero-argument !type-constraint"+    "!type-constraint(\"closed-world\")\ntrue"+    (ExpressionProgram (TypeEmit "closed-world" [] (BoolLit True)))++  it "does not confuse !type-constraint with an ordinary !expr emission" $+    parseProgram "!constraint(\"k\", 1)\ntrue"+      `shouldBe` Right (ExpressionProgram (Emit (Constrain "k" [NumberLit 1]) (BoolLit True)))

@@ -0,0 +1,217 @@+-- | v4-types resolution and canonical identity (roadmap-to-v4 Phase 9).+--+-- The load-bearing property here is the same one 'Tramaj.AnalysisSpec' and+-- "Tramaj.ParserSpec" already hold the language to: every case asserts the+-- exact string a canonical id renders to, not just that resolution+-- succeeded. That is what "two implementations must agree on the id+-- strings" (roadmap Phase 9, following Phase 4's own discipline for symbol+-- ids) means in practice -- this file and its PureScript sibling assert the+-- identical literal strings.+module Tramaj.TypesSpec (spec) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import Test.Hspec+import Tramaj.Analysis (unsuppliedTypeParams)+import Tramaj.Ast (Program, TypeExpr, typeDecls, unlets, programRoot)+import Tramaj.Parser+import Tramaj.Types++spec :: Spec+spec = do+  resolutionSpec+  errorSpec+  parameterSpec+  closureAndConstraintSpec++prog :: Text -> Program+prog src = either (\e -> error ("types fixture does not parse: " <> show e)) id (parseProgram src)++-- | The body of a @type Name = ...@ declaration, by name -- what every case+-- below resolves.+declBody :: Program -> Text -> TypeExpr+declBody p n = maybe (error ("no such declaration: " <> show n)) id (lookup n (typeDecls (fst (unlets (programRoot p)))))++resolvesTo :: Map.Map Text Program -> Program -> Text -> Text -> Spec+resolvesTo libs p declName expectedId =+  it (show declName <> " canonicalizes to " <> show expectedId) $+    fmap canonicalId (resolveTypeExpr libs p (declBody p declName)) `shouldBe` Right expectedId++resolutionSpec :: Spec+resolutionSpec = describe "canonical ids" $ do+  resolvesTo+    Map.empty+    (prog "type Tree = | Leaf | Node { l : Tree, r : Tree }\ntrue")+    "Tree"+    "|Leaf|Node {l:root:Tree,r:root:Tree}"++  resolvesTo+    Map.empty+    (prog "type Inner = { x : number }\ntype Outer = { items : [ Inner ] }\ntrue")+    "Outer"+    "{items:[root:Inner]}"++  resolvesTo+    (Map.fromList [("message", prog "type Envelope = { to : string, id : number }\ntrue")])+    (prog "@msg=import(\"message\", {})\ntype UsesEnvelope = { env : $msg.types.Envelope }\ntrue")+    "UsesEnvelope"+    "{env:\"message\":Envelope}"++  -- Sorted by arm/field name, regardless of source order -- the injectivity+  -- v4-types \S3 asks for depends on the id not encoding which order the+  -- author happened to write things in.+  resolvesTo+    Map.empty+    (prog "type Shape = | Square { s : number } | Circle { r : number } | Dev\ntrue")+    "Shape"+    "|Circle {r:number}|Dev|Square {s:number}"++  -- A root declaration and a same-named library declaration must render to+  -- different strings -- the whole point of \"root\" being a token no+  -- quoted library key can equal (see "Tramaj.Types"'s header).+  resolvesTo+    (Map.fromList [("message", prog "type Envelope = { to : string }\ntrue")])+    (prog "@msg=import(\"message\", {})\ntype Envelope = string\ntype Both = { local : Envelope, remote : $msg.types.Envelope }\ntrue")+    "Both"+    "{local:root:Envelope,remote:\"message\":Envelope}"++  resolvesTo+    Map.empty+    (prog "type Message = { to : string, payload : %ctx.payload }\ntrue")+    "Message"+    "{payload:%ctx.payload,to:string}"++  resolvesTo+    Map.empty+    (prog "type Items = [ string ]\ntrue")+    "Items"+    "[string]"++errorSpec :: Spec+errorSpec = describe "resolution errors" $ do+  it "reports UnresolvedType for a name that names no primitive and no declaration" $+    resolveTypeExpr Map.empty (prog "type Bad = NoSuchType\ntrue") (declBody (prog "type Bad = NoSuchType\ntrue") "Bad")+      `shouldBe` Left (UnresolvedType "NoSuchType")++  it "reports NotStaticallyResolvable when $lib is not bound directly to an import" $+    let p = prog "@x=1\n@msg=$x\ntype T = { e : $msg.types.Envelope }\ntrue"+     in resolveTypeExpr Map.empty p (declBody p "T") `shouldBe` Left (NotStaticallyResolvable "msg")++  it "reports NotStaticallyResolvable when the import names a library the table lacks" $+    let p = prog "@msg=import(\"missing\", {})\ntype T = { e : $msg.types.Envelope }\ntrue"+     in resolveTypeExpr Map.empty p (declBody p "T") `shouldBe` Left (NotStaticallyResolvable "msg")++  it "reports UnresolvedType for a name the library table resolves but does not declare" $+    let libs = Map.fromList [("message", prog "type Envelope = string\ntrue")]+        p = prog "@msg=import(\"message\", {})\ntype T = { e : $msg.types.Missing }\ntrue"+     in resolveTypeExpr libs p (declBody p "T") `shouldBe` Left (UnresolvedType "Missing")++-- | Type parameters through imports (v4-types \S2, roadmap Phase 10): a+-- 'RRef'\'s @arguments@ come from the import that reached it, not from any+-- syntax at the reference site itself.+parameterSpec :: Spec+parameterSpec = describe "type parameters through imports" $ do+  it "supplies a library-qualified type argument, closing the library's own hole" $+    let libs =+          Map.fromList+            [ ("json", prog "type Value = document\ntrue")+            , ("message", prog "type Envelope = { to : string, payload : %ctx.payload }\ntrue")+            ]+        p =+          prog+            "@json=import(\"json\", {})\n@msg=import(\"message\", {payload: %$json.types.Value})\ntype T = $msg.types.Envelope\ntrue"+     in fmap canonicalId (resolveTypeExpr libs p (declBody p "T")) `shouldBe` Right "\"message\":Envelope[payload=\"json\":Value]"++  it "supplies a bare local type name as a type argument" $+    let libs = Map.fromList [("message", prog "type Envelope = { payload : %ctx.payload }\ntrue")]+        p = prog "type Json = string\n@msg=import(\"message\", {payload: %Json})\ntype T = $msg.types.Envelope\ntrue"+     in fmap canonicalId (resolveTypeExpr libs p (declBody p "T")) `shouldBe` Right "\"message\":Envelope[payload=root:Json]"++  it "forwards a type hole through a nested import, closed only once the outer import supplies it" $+    let libs =+          Map.fromList+            [ ("inner", prog "type Box = { payload : %ctx.payload }\ntrue")+            , ("outer", prog "@in=import(\"inner\", {payload: %ctx.payload})\ntype Outer = $in.types.Box\ntrue")+            ]+        p = prog "@o=import(\"outer\", {payload: %string})\ntype T = $o.types.Outer\ntrue"+     in fmap canonicalId (resolveTypeExpr libs p (declBody p "T")) `shouldBe` Right "\"outer\":Outer[payload=string]"++  it "leaves an unsupplied type argument as a hole -- 'forward', not 'supply' (\\S6)" $+    let libs = Map.fromList [("message", prog "type Envelope = { payload : %ctx.payload }\ntrue")]+        p = prog "@msg=import(\"message\", {})\ntype T = $msg.types.Envelope\ntrue"+     in fmap canonicalId (resolveTypeExpr libs p (declBody p "T")) `shouldBe` Right "\"message\":Envelope[payload=%ctx.payload]"++  it "reports unsuppliedTypeParams for a parameterised import that supplies nothing" $+    let libs = Map.fromList [("outer", prog "@in=import(\"inner\", {payload: %ctx.payload})\ntrue")]+        p = prog "@o=import(\"outer\", {})\ntrue"+     in unsuppliedTypeParams libs p `shouldBe` [("outer", Set.singleton ["payload"])]++  it "requireClosed accepts a fully supplied type" $+    let libs = Map.fromList [("message", prog "type Envelope = { payload : %ctx.payload }\ntrue")]+        p = prog "@msg=import(\"message\", {payload: %string})\ntype T = $msg.types.Envelope\ntrue"+     in (resolveTypeExpr libs p (declBody p "T") >>= requireClosed) `shouldSatisfy` isRight++  it "requireClosed rejects a type that still contains a variable (\\S4's PartialType)" $+    let libs = Map.fromList [("message", prog "type Envelope = { payload : %ctx.payload }\ntrue")]+        p = prog "@msg=import(\"message\", {})\ntype T = $msg.types.Envelope\ntrue"+     in (resolveTypeExpr libs p (declBody p "T") >>= requireClosed)+          `shouldBe` Left (PartialType "\"message\":Envelope[payload=%ctx.payload]" ["payload"])++  it "reports TypeParamCollision when a params key is read both as $ctx.k and as %ctx.k" $+    let p = prog "@a=import(\"m\", {k: %ctx.k})\n@b=$ctx.k\ntrue"+     in checkTypeParamCollisions p `shouldBe` Left (TypeParamCollision "k")++  it "reports no collision when the two channels use different keys" $+    let p = prog "@a=import(\"m\", {k: %ctx.k})\n@b=$ctx.other\ntrue"+     in checkTypeParamCollisions p `shouldBe` Right ()++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight (Left _) = False++-- | The @\"types\"@ closure (\S8, roadmap Phase 13) and @!type-constraint@+-- collection (\S5, roadmap Phase 12).+closureAndConstraintSpec :: Spec+closureAndConstraintSpec = describe "output: closure and type constraints" $ do+  it "expands a parameterised reference's own definition, one declaration boundary at a time" $+    let libs =+          Map.fromList+            [ ("inner", prog "type Box = { payload : %ctx.payload }\ntrue")+            , ("outer", prog "@in=import(\"inner\", {payload: %ctx.payload})\ntype Outer = $in.types.Box\ntrue")+            ]+        p = prog "@o=import(\"outer\", {payload: %string})\ntype T = $o.types.Outer\ntrue"+        Right root = resolveTypeExpr libs p (declBody p "T")+        Right table = typeClosure libs p [root]+     in do+          Map.lookup "\"outer\":Outer[payload=string]" table `shouldBe` Just (RRef (Just "inner") "Box" [("payload", RPrim "string")])+          Map.lookup "\"inner\":Box[payload=string]" table `shouldBe` Just (RRecord [("payload", RPrim "string")])++  it "resolves a !type-constraint's arguments, mixing a type and a scalar" $+    let p = prog "type Json = string\n!type-constraint(\"coercible-to\", %Json, \"lossy\")\ntrue"+     in typeConstraints Map.empty p `shouldBe` Right [("coercible-to", [RCType (RRef Nothing "Json" []), RCScalarStr "lossy"])]++  it "deduplicates two type constraints with the same name and resolved arguments" $+    let p =+          prog+            "type Json = string\n!type-constraint(\"has-default\", %Json)\n!type-constraint(\"has-default\", %Json)\ntrue"+     in typeConstraints Map.empty p `shouldBe` Right [("has-default", [RCType (RRef Nothing "Json" [])])]++  it "typeReferences collects the canonical ids of a program's own type-bearing positions" $+    let p = prog "type Json = string\n!type-constraint(\"has-default\", %Json)\ntrue"+     in typeReferences Map.empty p `shouldBe` Right (Set.fromList ["root:Json", "string"])++  it "typeReferences resolves library-qualified references" $+    let libs = Map.fromList [("message", prog "type Envelope = { to : string }\ntrue")]+        p = prog "@msg=import(\"message\", {})\ntype T = $msg.types.Envelope\ntrue"+     in typeReferences libs p `shouldBe` Right (Set.fromList ["\"message\":Envelope"])++  it "deepTypeReferences follows transitively imported libraries" $+    let libs = Map.fromList [("message", prog "type Envelope = { to : string }\ntrue")]+        p = prog "@msg=import(\"message\", {})\ntype T = $msg.types.Envelope\ntrue"+     in deepTypeReferences libs p `shouldBe` Right (Set.fromList ["\"message\":Envelope", "{to:string}"])++  it "deepTypeConstraints bubbles up constraints from imported libraries" $+    let libs = Map.fromList [("typed", prog "type Json = string\n!type-constraint(\"has-default\", %Json)\ntrue")]+        p = prog "import(\"typed\", {}).rendered"+     in deepTypeConstraints libs p `shouldBe` Right [("has-default", [RCType (RRef Nothing "Json" [])])]

@@ -0,0 +1,84 @@+cabal-version:      3.4+name:               tramaj-hs+version:            0.3.0.0+synopsis:           Haskell parser/AST/evaluator for the tramaj language+description:+  Parser, AST and evaluator for the tramaj language specified in+  @specs\/reference.md@ at the root of this repository -- a small+  HAML-like template language with a bindings prelude, closures, and+  @map@\/@filter@\/@scan@, designed to be written by humans and LLMs and+  rendered against a JSON context.+  .+  This is an independent Haskell port of the PureScript implementation+  under @..\/tramaj@, built on megaparsec + aeson rather than shared+  via FFI, so a host can evaluate a template server-side and not only in+  the browser. Both implementations target the same grammar and are kept+  in agreement by hand-ported test fixtures; see the repository README for+  the caveats that come with that.+homepage:           https://github.com/lucasdicioccio/templating-lang+bug-reports:        https://github.com/lucasdicioccio/templating-lang/issues+license:            MIT+license-file:       LICENSE+author:             Lucas DiCioccio+maintainer:         lucas.dicioccio@gmail.com+category:           Text+build-type:         Simple+extra-doc-files:    CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/lucasdicioccio/templating-lang.git+  subdir:   tramaj-hs++common defaults+  default-language:   GHC2021+  default-extensions:+    DeriveAnyClass+    DerivingStrategies+    LambdaCase+    OverloadedStrings+  ghc-options:        -Wall -Wno-name-shadowing++library+  import:           defaults+  hs-source-dirs:   src+  exposed-modules:+    Tramaj.Analysis+    Tramaj.Ast+    Tramaj.Eval+    Tramaj.Node+    Tramaj.Parser+    Tramaj.Types+  build-depends:+    , base            >=4.19  && <4.22+    , aeson           >=2.1   && <2.4+    , containers      >=0.6   && <0.9+    , megaparsec      >=9.5   && <9.9+    , scientific      >=0.3   && <0.4+    , text            >=2.0   && <2.2+    , vector          >=0.13  && <0.14++test-suite unit+  import:           defaults+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test/unit+  main-is:          Main.hs+  other-modules:+    Tramaj.AnalysisSpec+    Tramaj.CorpusSpec+    Tramaj.EvalSpec+    Tramaj.NodeJsonSpec+    Tramaj.ParserSpec+    Tramaj.TypesSpec+  build-depends:+    , base+    , aeson+    , bytestring+    , containers+    , directory+    , filepath+    , hspec        >=2.11+    , tramaj-hs+    , text+    , vector+  build-tool-depends: hspec-discover:hspec-discover