diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/src/Tramaj/Analysis.hs b/src/Tramaj/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Tramaj/Analysis.hs @@ -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 diff --git a/src/Tramaj/Ast.hs b/src/Tramaj/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Tramaj/Ast.hs @@ -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') diff --git a/src/Tramaj/Eval.hs b/src/Tramaj/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Tramaj/Eval.hs @@ -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\": , \"path\": [, ...]}") + | 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 diff --git a/src/Tramaj/Node.hs b/src/Tramaj/Node.hs new file mode 100644 --- /dev/null +++ b/src/Tramaj/Node.hs @@ -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 diff --git a/src/Tramaj/Parser.hs b/src/Tramaj/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Tramaj/Parser.hs @@ -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)) "" diff --git a/src/Tramaj/Types.hs b/src/Tramaj/Types.hs new file mode 100644 --- /dev/null +++ b/src/Tramaj/Types.hs @@ -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) diff --git a/test/unit/Main.hs b/test/unit/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/unit/Tramaj/AnalysisSpec.hs b/test/unit/Tramaj/AnalysisSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/AnalysisSpec.hs @@ -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)] diff --git a/test/unit/Tramaj/CorpusSpec.hs b/test/unit/Tramaj/CorpusSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/CorpusSpec.hs @@ -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 + [] -> "" diff --git a/test/unit/Tramaj/EvalSpec.hs b/test/unit/Tramaj/EvalSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/EvalSpec.hs @@ -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) diff --git a/test/unit/Tramaj/NodeJsonSpec.hs b/test/unit/Tramaj/NodeJsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/NodeJsonSpec.hs @@ -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) diff --git a/test/unit/Tramaj/ParserSpec.hs b/test/unit/Tramaj/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/ParserSpec.hs @@ -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))) diff --git a/test/unit/Tramaj/TypesSpec.hs b/test/unit/Tramaj/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/TypesSpec.hs @@ -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" [])])] diff --git a/tramaj-hs.cabal b/tramaj-hs.cabal new file mode 100644 --- /dev/null +++ b/tramaj-hs.cabal @@ -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