tramaj-hs 0.3.0.0 → 0.4.0.0

raw patch · 17 files changed

+2174/−589 lines, 17 filesdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• CHANGELOG.md +89/−2
• src/Tramaj/Analysis.hs +59/−0
• src/Tramaj/Ast.hs +26/−5
• src/Tramaj/Eval.hs +611/−236
• src/Tramaj/Json.hs +275/−0
• src/Tramaj/Node.hs +56/−45
• src/Tramaj/Parser.hs +39/−20
• src/Tramaj/Types.hs +9/−4
• test/unit/Tramaj/AnalysisSpec.hs +104/−1
• test/unit/Tramaj/CorpusSpec.hs +186/−19
• test/unit/Tramaj/EvalSpec.hs +324/−171
• test/unit/Tramaj/JsonSpec.hs +238/−0
• test/unit/Tramaj/NodeJsonSpec.hs +68/−66
• test/unit/Tramaj/ParserSpec.hs +40/−14
• test/unit/Tramaj/TestJson.hs +41/−0
• test/unit/Tramaj/TypesSpec.hs +4/−4
• tramaj-hs.cabal +5/−2

@@ -1,5 +1,94 @@ # Changelog +## 0.4.0.0++**Breaking: integers and floats are two number types** (`../specs/decisions.md`+\S18, `../specs/reference.md` \S3). A literal or a JSON number with neither a+fraction nor an exponent is an integer; one with either is a float. Nothing+converts between them: `eq(1, 1.0)` is `false`, `lt`/`lte`/`gt`/`gte` over an+integer and a float are a `TypeMismatch`, and `has`/`lookup` take an integer+index. The integer range is the signed 64-bit one; an integer literal outside+it is a parse error and a context integer outside it a `TypeMismatch`. A+float is written with a fraction or an exponent everywhere, so `str(1.0)` is+`1.0` where it was `1`. The arithmetic builtins are not part of this.++New `Tramaj.Json`: a JSON value with `JInt` and `JFloat`, `jsonParser` (which+types a number by its text) and `stringify`. `evalProgram`, `runProgram`,+`Output`, `Node`, `NodeAttribute`, `Annotations`, `nodeToJson`,+`nodeFromJson`, `nodeAttributeToJson` and `mapActions` use it where they used+`Data.Aeson.Value`, which holds one number type; `fromAeson` and `toAeson`+bridge the two. `NumberLit` is split into `IntLit`/`FloatLit`, `TCScalarNum`+into `TCScalarInt`/`TCScalarFloat` and `RCScalarNum` into+`RCScalarInt`/`RCScalarFloat`. The type primitive `number` is gone; `int` and+`float` replace it. Needs `aeson >= 2.2.1`, for its token decoder.++**The arithmetic profile** (`../specs/reference.md` \S9, \S11, \S12,+`../specs/v3-symbols.md` \S1.9, \S5.2 to \S5.5), as an option of one+evaluation that is off by default. Nine builtins: `sum`, `product`, `negate`,+`inverse`, `quotient`, `floor-quotient`, `modulo`, `floor` and `real`, over+the two number types with no conversion or promotion. Integer results are+held to the signed 64-bit range at every step of a fold and nothing wraps;+float results are one correctly rounded double operation at a time, in a left+fold. Over a symbol they build a term, written+`{"$term": <op>, "arguments": [...]}`, which crosses wherever a symbol does+and is refused wherever a symbol is.++New in `Tramaj.Eval`: `Options (..)` (`optMode`, `optArithmetic`),+`defaultOptions` (concrete mode, arithmetic off), `evalProgramWith` and+`runProgramWith`, which take an `Options` where `evalProgram` and+`runProgram` take a `Mode`. Those two keep their signatures and run without+the profile, so the nine names stay unbound there and `sum(1, 2)` is an+`UnboundName`. The option applies to the root and to every library the+evaluation runs. New in `Tramaj.Analysis`: `arithmeticNames`, `arithmeticOps`+and `deepArithmeticOps`, which report the arithmetic names a program+references free, so a host that leaves the profile off can refuse a program+before running it.++**Breaking**, with or without the profile:++- `EvalError` gains the constructor `NotRepresentable`: integer overflow, a+  zero divisor, a float result that is not finite. A host that matches every+  constructor needs a case for it.+- `"$term"` joins `"$sym"` and `"$type"` as a reserved key. `{"$term": 1}` in+  a program is a parse error, and a context carrying that key is a+  `TypeMismatch`, in concrete mode always and in symbolic mode unless it is a+  well-formed term and the profile is on.++**Sorting, number formatting and `round`** (`../specs/decisions.md` \S20,+`../specs/reference.md` \S11).++- `sort-by(list, fn)` and `sort-by-descending(list, fn)` order a list by the+  key `fn` gives each element. Keys are all integers, all floats or all+  strings (compared by code point); anything else is a `TypeMismatch`, and a+  symbol or a term a `NotConcrete`. Both are stable, each on its own terms,+  and `fn` is applied once per element, in index order. They are core+  forms, in every profile.+- `format-number(x, decimals, group)` writes an integer or a float in+  positional decimal notation with `decimals` digits (0 to 20) after the+  point and `group` between the groups of three digits of the integer part.+  It rounds the exact value of the number, ties away from zero, never writes+  an exponent or a negative zero, and has no locale. An ordinary builtin, in+  every profile.+- `round(x)` is the tenth builtin of the arithmetic profile: the integer+  nearest to `x`, ties away from zero, a `NotRepresentable` outside the+  integer range, and a term over a symbol.++**Breaking:**++- `Expr` gains the constructor `SortBy Bool Expr Expr` (descending,+  collection, key function). A host that matches every constructor needs a+  case for it; `subExprs` and every analysis already traverse it.+- `sort-by` and `sort-by-descending` are special-form names, as `map` is. A+  program that bound one of them and called it (`$sort-by(...)`) now gets+  the form, or a parse error if the call does not have two arguments.+- `format-number` joins `builtinNames`, and `round` joins `arithmeticNames`,+  so `arithmeticOps` reports it. A program that binds either name still+  shadows it.++New in `Tramaj.Eval`: `emittedConstraintCount`, the number of constraints an+evaluation emitted before equal ones are made one. It is there for tests,+which have no other way to count the applications of a function.+ ## 0.3.0.0  Implements v2 of the language. This is a rewrite of the semantic core, not an@@ -63,8 +152,6 @@ 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

@@ -29,6 +29,9 @@   , symbolSites   , symbolDemands   , deepSymbolDemands+  , arithmeticNames+  , arithmeticOps+  , deepArithmeticOps   , typeDeclarations   , typeParams   , unsuppliedTypeParams@@ -256,6 +259,62 @@ deepSymbolDemands libs prog =   symbolDemands prog     <> foldMap (maybe Set.empty symbolDemands . flip Map.lookup libs) (transitiveImportNames libs prog)++-- Arithmetic -------------------------------------------------------------------++-- | The ten names of the arithmetic profile (reference.md \S11), @round@+-- being the tenth (decisions \S20). They are+-- names and not syntax: an evaluation with the profile on binds them in the+-- initial environment ('Tramaj.Eval.optArithmetic'), and a program may bind+-- any of them itself.+arithmeticNames :: [Text]+arithmeticNames =+  [ "sum"+  , "product"+  , "negate"+  , "inverse"+  , "quotient"+  , "floor-quotient"+  , "modulo"+  , "floor"+  , "real"+  , "round"+  ]++-- | Which of 'arithmeticNames' this program references free (reference.md+-- \S9), called (@sum(1, 2)@) or passed by reference (@fold($xs, 0, $sum)@)+-- alike, since both are a 'Path' rooted at the name.+--+-- Scope-aware: a name bound by a binding, a lambda parameter or a pattern+-- name is not reported where that binding is in scope. A pattern is lowered+-- to plain bindings by the parser, so it needs no case here. A binding's own+-- right-hand side is outside its scope, so @\@sum = sum(1, 2)@ reports+-- @sum@.+--+-- Over-approximates like every analysis here: a name used only under a+-- 'Branch' arm no context will select is still reported.+arithmeticOps :: Program -> Set Text+arithmeticOps = go Set.empty . programRoot+  where+    go bound = \case+      Path root _+        | root `elem` arithmeticNames && not (Set.member root bound) -> Set.singleton root+        | otherwise -> Set.empty+      Let name value body -> go bound value <> go (Set.insert name bound) body+      TypeAnnotate name _ value body -> go bound value <> go (Set.insert name bound) body+      Lambda params body -> go (Set.union (Set.fromList params) bound) body+      other -> foldMap (go bound) (subExprs other)++-- | 'arithmeticOps' of this program and of every library it imports,+-- directly or not. A library has its own scope, so a binding in the+-- importing program shadows nothing there. This is what a host that leaves+-- the arithmetic profile off checks before running a program: non-empty+-- means the program would fail with 'Tramaj.Eval.UnboundName', and with the+-- profile on it names the operations a term can carry (v3-symbols \S7).+deepArithmeticOps :: Map Text Program -> Program -> Set Text+deepArithmeticOps libs prog =+  arithmeticOps prog+    <> foldMap (maybe Set.empty arithmeticOps . flip Map.lookup libs) (transitiveImportNames libs prog)  -- Types ----------------------------------------------------------------------- 

@@ -43,6 +43,7 @@   , numberAllocs   ) where +import Data.Int (Int64) import Data.Text (Text) import qualified Data.Text as T @@ -84,7 +85,13 @@     -- ones.     Let Text Expr Expr   | StringLit Text-  | NumberLit Double+  | -- | A number literal with neither a fraction nor an exponent+    -- (reference.md \S5): an integer, denoting exactly its value. The parser+    -- refuses one outside the signed 64-bit range.+    IntLit Int64+  | -- | A number literal with a fraction or an exponent: a float, the+    -- finite double nearest to its decimal value, never a negative zero.+    FloatLit Double   | BoolLit Bool   | NullLit   | ArrayLit [Expr]@@ -106,6 +113,12 @@   | Filter Expr Expr   | Scan Expr Expr Expr   | Fold Expr Expr Expr+  | -- | @sort-by(collection, function)@ and, with the flag set,+    -- @sort-by-descending(collection, function)@ (reference.md \S11,+    -- /Sorting/): the elements of the collection ordered by the key the+    -- function gives each of them. A core constructor for the reason 'Map'+    -- is one: the key function needs a fresh binding per element.+    SortBy Bool 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@@ -177,7 +190,8 @@ data TypeConstraintArg   = TCType TypeExpr   | TCScalarStr Text-  | TCScalarNum Double+  | TCScalarInt Int64+  | TCScalarFloat Double   | TCScalarBool Bool   | TCScalarNull   deriving stock (Eq, Show)@@ -191,7 +205,7 @@ -- 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+-- to classify: the six primitive names are a closed, reserved lexical set -- (v4-types \S1), not ordinary identifiers that happen to resolve to a -- primitive. data TypeExpr@@ -284,7 +298,8 @@ subExprs (Lambda _ body) = [body] subExprs (Let _ value body) = [value, body] subExprs (StringLit _) = []-subExprs (NumberLit _) = []+subExprs (IntLit _) = []+subExprs (FloatLit _) = [] subExprs (BoolLit _) = [] subExprs NullLit = [] subExprs (ArrayLit elems) = elems@@ -296,6 +311,7 @@ subExprs (Filter coll fn) = [coll, fn] subExprs (Scan coll initial fn) = [coll, initial, fn] subExprs (Fold coll initial fn) = [coll, initial, fn]+subExprs (SortBy _ coll fn) = [coll, fn] subExprs (Concat l r) = [l, r] subExprs (Import _ params) = [e | (_, PExpr e) <- params] subExprs (AdaptActions target _ fn) = target : maybe [] pure fn@@ -408,7 +424,8 @@           (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'@(IntLit _) = (n, e')+    go n e'@(FloatLit _) = (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')@@ -443,6 +460,10 @@           (n2, initial') = go n1 initial           (n3, fn') = go n2 fn        in (n3, Fold coll' initial' fn')+    go n (SortBy descending coll fn) =+      let (n1, coll') = go n coll+          (n2, fn') = go n1 fn+       in (n2, SortBy descending coll' fn')     go n (Concat l r) =       let (n1, l') = go n l           (n2, r') = go n1 r

@@ -20,38 +20,37 @@   ( EvalError (..)   , Output (..)   , Mode (..)+  , Options (..)+  , defaultOptions   , LibraryTable   , evalProgram+  , evalProgramWith   , runProgram+  , runProgramWith   , evalExprWith+  , emittedConstraintCount   , builtinNames   ) where -import Data.Aeson (Value (..), encode)-import qualified Data.Aeson.Key as Key-import qualified Data.Aeson.KeyMap as KeyMap+import Control.Monad (foldM) 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)+import Data.Int (Int64)+import Data.List (sortBy)+#if __GLASGOW_HASKELL__ < 910+import Data.List (foldl') #endif+import Data.Ord (Down (..), comparing) 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.Analysis (arithmeticNames, symbolSites) import Tramaj.Ast+import Tramaj.Json (Json (..), inIntegerRange, normalizeNumbers, stringify) import Tramaj.Node import Tramaj.Types (ResolvedConstraintArg (..), ResolvedType (..), TypeError, canonicalId, deepTypeConstraints, eraseTypes, programTypeRoots, typeClosure) @@ -92,6 +91,11 @@     -- -- but 'Tramaj.Types.TypeError' still needs a home in the one error     -- type every entry point already returns.     TypeErr TypeError+  | -- | An arithmetic operation has no result in the type of its operands+    -- (reference.md \S11, \S12): an integer result outside the integer+    -- range, a zero divisor, a float result that is not finite. Nothing+    -- wraps, saturates or rounds instead.+    NotRepresentable Text   deriving stock (Eq, Show)  -- | What a program produced. Which one it is follows from the value the root@@ -99,7 +103,7 @@ -- root is @$header@ yields a document if that binding holds one. data Output   = ONode Node-  | OValue Value+  | OValue Json   deriving stock (Eq, Show)  -- | A host parameter, not a property of the program (v3-symbols \S5): what an@@ -111,6 +115,31 @@ data Mode = Concrete | Symbolic   deriving stock (Eq, Show) +-- | What a host chooses for one evaluation. Like 'Mode', each field is a+-- host parameter and not a property of the program.+--+-- 'optArithmetic' is reference.md \S11's arithmetic profile, per+-- evaluation: with it on, the ten names of+-- 'Tramaj.Analysis.arithmeticNames' are in the initial environment of the+-- program and of every library it runs, and a seeded term is accepted in+-- symbolic mode (v3-symbols \S5.4). With it off they are unbound, so a+-- program that uses one fails with 'UnboundName', and every seeded term is+-- refused. The two number types and the reserved @"$term"@ key do not+-- depend on it.+data Options = Options+  { optMode :: Mode+  , optArithmetic :: Bool+  }+  deriving stock (Eq, Show)++-- | Concrete mode, without the arithmetic profile. 'evalProgram' and+-- 'runProgram' run with these options and the mode they are given. The+-- profile is off unless a host asks for it, so that a host which has not+-- opted in never receives a term, and can refuse a program up front with+-- 'Tramaj.Analysis.deepArithmeticOps'.+defaultOptions :: Options+defaultOptions = Options {optMode = Concrete, optArithmetic = False}+ -- | 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'.@@ -125,10 +154,15 @@ -- -- There is no recursion: 'Let' inserts a binding only after evaluating its -- right-hand side, so a closure cannot see its own name.+--+-- A number is an integer or a float (reference.md \S3), and nothing here+-- converts one into the other. 'VInt' covers the signed 64-bit range;+-- 'VFloat' holds a finite double that is never a negative zero. data Value'   = VNull   | VBool Bool-  | VNumber Scientific+  | VInt Int64+  | VFloat Double   | VString Text   | VArray [Value']   | VObject (Map Text Value')@@ -148,6 +182,13 @@     -- demand (@?ctx.path@) once minted -- its own path is baked into the id,     -- not carried here.     VSymbol SymbolId [Text]+  | -- | A term (\S1.9): an arithmetic operation left unevaluated because one+    -- of its operands is a symbol or a term. It holds the name of the+    -- builtin and its operands exactly as the call had them once flattened:+    -- each a 'VInt', a 'VFloat', a 'VSymbol' or a 'VTerm', nothing folded+    -- and no nested term spliced. It is data as a symbol is, and is refused+    -- wherever a symbol is.+    VTerm Text [Value']  type Env = Map Text Value' @@ -173,7 +214,7 @@ -- 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+  = OAlloc Int Json   | ODemand [Text]   deriving stock (Eq, Show) @@ -201,11 +242,15 @@ -- 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.+-- 'ecArithmetic' is whether the arithmetic profile is on ('Options'): the+-- same for the root and for every library, since it is what the host+-- enabled. data EvalCtx = EvalCtx   { ecLibs :: LibraryTable   , ecInProgress :: Set Text   , ecMode :: Mode   , ecIsRoot :: Bool+  , ecArithmetic :: Bool   }  -- | Enters a library: adds it to the in-progress set (so re-entering it is a@@ -291,25 +336,42 @@ -- 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+evalProgram :: Mode -> LibraryTable -> Json -> Program -> Either EvalError Output+evalProgram mode = evalProgramWith defaultOptions {optMode = mode} +-- | As 'evalProgram', with every per-evaluation option given ('Options').+evalProgramWith :: Options -> LibraryTable -> Json -> Program -> Either EvalError Output+evalProgramWith options libs input prog = fst <$> evalProgramWithEmissions options 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)+evalProgramWithEmissions :: Options -> LibraryTable -> Json -> Program -> Either EvalError (Output, Emissions)+evalProgramWithEmissions options libs input prog = do+  (v, emitted) <- evalProgramRaw options libs input prog   output <- case v of     VNode' n -> Right (ONode n)     other -> OValue <$> toJson other   pure (output, dedupe emitted) +-- | The value of a program and everything it emitted, in evaluation order+-- and before 'dedupe'.+evalProgramRaw :: Options -> LibraryTable -> Json -> Program -> Either EvalError (Value', Emissions)+evalProgramRaw options libs input prog = do+  erased <- first TypeErr (eraseTypes libs prog)+  runEval $ do+    ctx <- liftEither (checkedFromJson options input)+    evalExpr (rootCtx options libs) (initialEnv (optArithmetic options) ctx) (programRoot erased)++-- | How many constraints an evaluation emitted, counted before 'dedupe'+-- makes equal ones one. No program and no output can tell this number: it+-- is here for tests, as the one way to count how many times a function was+-- applied, which reference.md \S11 fixes for the key function of a sort.+emittedConstraintCount :: Options -> LibraryTable -> Json -> Program -> Either EvalError Int+emittedConstraintCount options libs input prog =+  length . emConstraints . snd <$> evalProgramRaw options libs input prog+ -- | 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@@ -346,13 +408,17 @@ -- 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+runProgram :: Mode -> LibraryTable -> Json -> Program -> Either EvalError Json+runProgram mode = runProgramWith defaultOptions {optMode = mode}++-- | As 'runProgram', with every per-evaluation option given ('Options').+runProgramWith :: Options -> LibraryTable -> Json -> Program -> Either EvalError Json+runProgramWith options libs input prog = do+  result <- evalProgramWithEmissions options libs input prog+  typesInfo <- case optMode options of     Concrete -> Right (Map.empty, [])     Symbolic -> first TypeErr (buildTypesInfo libs prog)-  pure (renderOutput mode typesInfo result)+  pure (renderOutput (optMode options) typesInfo result)  -- | The @\"types\"@ table's entries and the deduplicated @\"type-constraints\"@ -- list (v4-types \S8, roadmap Phase 13), computed from @prog@ /before/@@ -369,112 +435,130 @@   tcs <- deepTypeConstraints libs prog   pure (closure, tcs) -renderOutput :: Mode -> (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])]) -> (Output, Emissions) -> Value+renderOutput :: Mode -> (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])]) -> (Output, Emissions) -> Json 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)))-        ]-    )+  object+    [ ("format", JString "tramaj/symbolic/1")+    , ("kind", JString kind)+    , ("root", root)+    , ("symbols", JArray (map symbolEntryToJson symbols))+    , ("constraints", JArray (map constraintToJson constraints))+    , ("types", JArray (map typeEntryToJson (Map.toList typesTable)))+    , ("type-constraints", JArray (map typeConstraintToJson typeConstraintsList))+    ]   where     (kind, root) = case output of       ONode n -> ("document", nodeToJson n)       OValue v -> ("expression", v) +object :: [(Text, Json)] -> Json+object = JObject . Map.fromList+ -- | One @\"types\"@ table entry (v4-types \S8): the id, and the definition -- behind it, rendered by 'resolvedTypeToJson'.-typeEntryToJson :: (Text, ResolvedType) -> Value+typeEntryToJson :: (Text, ResolvedType) -> Json typeEntryToJson (tid, rt) =-  Object (KeyMap.fromList [("id", String tid), ("definition", resolvedTypeToJson rt)])+  object [("id", JString 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 :: ResolvedType -> Json+resolvedTypeToJson (RPrim name) = object [("kind", JString "prim"), ("name", JString name)]+resolvedTypeToJson (RArray t) = object [("kind", JString "array"), ("element", resolvedTypeToJson t)] resolvedTypeToJson (RRecord fields) =-  Object (KeyMap.fromList [("kind", String "record"), ("fields", Array (V.fromList (map field fields)))])+  object [("kind", JString "record"), ("fields", JArray (map field fields))]   where-    field (name, t) = Object (KeyMap.fromList [("name", String name), ("type", resolvedTypeToJson t)])+    field (name, t) = object [("name", JString name), ("type", resolvedTypeToJson t)] resolvedTypeToJson (RUnion arms) =-  Object (KeyMap.fromList [("kind", String "union"), ("arms", Array (V.fromList (map arm arms)))])+  object [("kind", JString "union"), ("arms", JArray (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)))])+      object (("name", JString name) : maybe [] (\t -> [("payload", resolvedTypeToJson t)]) mt)+resolvedTypeToJson r@(RRef _ _ _) = object [("kind", JString "ref"), ("id", JString (canonicalId r))]+resolvedTypeToJson (RVar path) = object [("kind", JString "var"), ("path", JArray (map JString 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 :: (Text, [ResolvedConstraintArg]) -> Json typeConstraintToJson (name, args) =-  Object (KeyMap.fromList [("name", String name), ("arguments", Array (V.fromList (map arg args)))])+  object [("name", JString name), ("arguments", JArray (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+    arg (RCType rt) = object [("$type", JString (canonicalId rt))]+    arg (RCScalarStr s) = JString s+    arg (RCScalarInt n) = JInt (toInteger n)+    arg (RCScalarFloat n) = JFloat n+    arg (RCScalarBool b) = JBool b+    arg RCScalarNull = JNull  -- | 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 :: Value' -> Json 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)+  object+    [ ("name", JString name)+    , ("arguments", JArray (map (either (const JNull) id . toJson) args))+    ]+constraintToJson other = either (const JNull) 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 -> Json symbolEntryToJson (SymbolEntry sid origin binding) =-  Object-    ( KeyMap.fromList-        [ ("id", String sid)-        , ("origin", originToJson origin)-        , ("binding", maybe Null String binding)-        ]-    )+  object+    [ ("id", JString sid)+    , ("origin", originToJson origin)+    , ("binding", maybe JNull JString binding)+    ]   where     originToJson (OAlloc site key) =-      Object (KeyMap.fromList [("kind", String "alloc"), ("site", Number (fromIntegral site)), ("key", key)])+      object [("kind", JString "alloc"), ("site", JInt (toInteger site)), ("key", key)]     originToJson (ODemand path) =-      Object (KeyMap.fromList [("kind", String "demand"), ("path", Array (V.fromList (map String path)))])+      object [("kind", JString "demand"), ("path", JArray (map JString 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'.+-- 'evalExpr' directly inside 'Eval'. Runs without the arithmetic profile,+-- as 'evalProgram' does. 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)+  fst <$> runEval (evalExpr (rootCtx options libs) (initialEnv (optArithmetic options) ctx) e)+  where+    options = defaultOptions {optMode = mode} -initialEnv :: Value' -> Env-initialEnv ctx = Map.insert "ctx" ctx (Map.fromList [(n, VBuiltin n) | n <- builtinNames])+-- | Where the evaluation of a root program starts.+rootCtx :: Options -> LibraryTable -> EvalCtx+rootCtx options libs =+  EvalCtx+    { ecLibs = libs+    , ecInProgress = Set.empty+    , ecMode = optMode options+    , ecIsRoot = True+    , ecArithmetic = optArithmetic options+    } --- | 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'.+-- | @$ctx@ and the builtins. The ten arithmetic names are bound only with+-- the arithmetic profile on (reference.md \S11); without it they are+-- ordinary unbound names.+initialEnv :: Bool -> Value' -> Env+initialEnv arithmeticOn ctx = Map.insert "ctx" ctx (Map.fromList [(n, VBuiltin n) | n <- names])+  where+    names = if arithmeticOn then builtinNames <> arithmeticNames else builtinNames++-- | The fixed builtin vocabulary of every profile; the arithmetic profile+-- adds 'Tramaj.Analysis.arithmeticNames' to it. 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"@@ -490,6 +574,7 @@   , "gte"   , "has"   , "lookup"+  , "format-number"   , "concat"   , "append"   ]@@ -517,7 +602,8 @@   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 _ _ (IntLit n) = pure (VInt n)+evalExpr _ _ (FloatLit n) = pure (VFloat n) evalExpr _ _ (BoolLit b) = pure (VBool b) evalExpr _ _ NullLit = pure VNull evalExpr ctx env (ArrayLit elems) =@@ -555,6 +641,25 @@   acc0 <- evalExpr ctx env initExpr   fnVal <- evalExpr ctx env fnExpr   foldSteps ctx fnVal acc0 items+-- | reference.md \S11, /Sorting/. The checks come in the order the+-- reference gives them: the collection, then, element by element in index+-- order, the key function's application and the key it gave. Only then is+-- anything reordered, so the key function runs exactly once per element.+--+-- 'sortBy' is a stable merge sort, and so is the one over 'Down': elements+-- whose keys are equal keep their input order under both names, which makes+-- the descending sort something other than the reversal of the ascending+-- one.+evalExpr ctx env (SortBy descending collExpr fnExpr) = do+  items <- evalCollection ctx env who collExpr+  fnVal <- evalExpr ctx env fnExpr+  keyed <- sortKeys ctx who fnVal items+  pure (VArray (map snd (ordered keyed)))+  where+    who = if descending then "sort-by-descending" else "sort-by"+    ordered+      | descending = sortBy (comparing (Down . fst))+      | otherwise = sortBy (comparing fst) evalExpr ctx env (Concat leftExpr rightExpr) = do   l <- evalExpr ctx env leftExpr   r <- evalExpr ctx env rightExpr@@ -752,23 +857,67 @@   next <- apply ctx "fold" fnVal [acc, item]   foldSteps ctx fnVal next rest +-- | What a sort orders by (reference.md \S11, /Sorting/). The keys of one+-- call all have the same constructor, which 'sortKeys' checks, so the+-- derived order only ever compares two integers, two floats or two strings.+-- A float key is never a NaN and never a negative zero (\S3), so its order+-- is total; 'Text' compares by code point.+data SortKey+  = KeyInt Int64+  | KeyFloat Double+  | KeyString Text+  deriving stock (Eq, Ord)++-- | Each element with its key: the key function is applied once per+-- element, in index order, and each key is checked as soon as it is known,+-- so the first element whose application or key fails decides the error. A+-- symbol or a term as a key is 'NotConcrete'; a value of a kind that is+-- never a key, or of another type than the first key, is a 'TypeMismatch'.+sortKeys :: EvalCtx -> Text -> Value' -> [Value'] -> Eval [(SortKey, Value')]+sortKeys ctx who fnVal = go Nothing+  where+    go _ [] = pure []+    go firstKey (item : rest) = do+      key <- apply ctx who fnVal [item] >>= liftEither . asKey+      case firstKey of+        Just k0 | not (sameType k0 key) ->+          evalError (TypeMismatch (who <> " expects keys of one type, got " <> describeKey k0 <> " and then " <> describeKey key))+        _ -> ((key, item) :) <$> go (Just (maybe key id firstKey)) rest++    asKey (VInt n) = Right (KeyInt n)+    asKey (VFloat d) = Right (KeyFloat d)+    asKey (VString s) = Right (KeyString s)+    asKey v+      | isSymbolic v = Left (NotConcrete who)+      | otherwise = Left (TypeMismatch (who <> " expects a key that is an integer, a float or a string, got " <> describeValue v))++    sameType (KeyInt _) (KeyInt _) = True+    sameType (KeyFloat _) (KeyFloat _) = True+    sameType (KeyString _) (KeyString _) = True+    sameType _ _ = False++    describeKey :: SortKey -> Text+    describeKey (KeyInt _) = "an integer"+    describeKey (KeyFloat _) = "a float"+    describeKey (KeyString _) = "a string"+ 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)+    VTerm _ _ -> 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.+-- side being a symbol or a term is 'NotConcrete' (v3-symbols \S1.5, \S1.9),+-- 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 l r | isSymbolic l || isSymbolic r = 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))@@ -815,7 +964,7 @@       mapEvalError (InLibrary name) $ do         let ctx' = enterLibrary name ctx             (statements, root) = unlets (programRoot prog)-        libEnv <- foldlEval (bindStep ctx') (initialEnv ctxVal) statements+        libEnv <- foldlEval (bindStep ctx') (initialEnv (ecArithmetic ctx) 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)))]))@@ -867,18 +1016,18 @@ -- 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 :: EvalCtx -> ActionAdaptation -> Maybe Value' -> Text -> Text -> Json -> 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+        JObject obj -> do+          event' <- liftEither $ case Map.lookup "eventType" obj of+            Just (JString 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)+          let payload' = maybe JNull id (Map.lookup "payload" obj)           pure (NAction event' key' payload')         _ -> evalError (TypeMismatch "adapt-actions: the function must return an object with an eventType field")   where@@ -911,6 +1060,8 @@   -- 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))+  -- A term has no projection (\S1.9): it stands for a number, and a number+  -- has no fields, so it gets the 'TypeMismatch' a number gets.   other ->     evalError       ( TypeMismatch@@ -926,13 +1077,14 @@ -- 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 :: Value' -> Either EvalError Json+toJson VNull = Right JNull+toJson (VBool b) = Right (JBool b)+toJson (VInt n) = Right (JInt (toInteger n))+toJson (VFloat n) = Right (JFloat n)+toJson (VString s) = Right (JString s)+toJson (VArray xs) = JArray <$> traverse toJson xs+toJson (VObject o) = JObject <$> traverse toJson 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@@ -941,7 +1093,13 @@ -- 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)))]))+  Right (object [("$sym", JString sid), ("path", JArray (map JString path))])+-- | A term crosses wherever a symbol does, as \S5.3's other tagged shape.+-- Its operands are numbers, symbols and terms, so they always cross, and+-- each number keeps its type (@1@ and @1.0@ stay distinct), which the+-- residual law depends on.+toJson (VTerm op operands) =+  (\args -> object [("$term", JString op), ("arguments", JArray args)]) <$> traverse toJson operands 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")@@ -954,47 +1112,87 @@         )     ) -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)))+-- | A JSON value this evaluator produced, back as a 'Value'', so its+-- numbers are already values: nothing is checked. The context goes through+-- 'checkedFromJson' instead.+fromJson :: Json -> Value'+fromJson JNull = VNull+fromJson (JBool b) = VBool b+fromJson (JInt n) = VInt (fromInteger n)+fromJson (JFloat n) = VFloat n+fromJson (JString s) = VString s+fromJson (JArray xs) = VArray (map fromJson xs)+fromJson (JObject o) = VObject (fmap fromJson o) --- | The input context's boundary: as 'fromJson', but recursively refusing--- @"$sym"@ and @"$type"@ as ordinary object keys (v3-symbols \S5.3). In--- concrete mode either key is refused unconditionally. In symbolic mode,--- seeding (\S5.4) accepts a well-formed @{"$sym": ..., "path": [...]}@ back--- as an actual symbol -- anything else carrying @"$sym"@, or @"$type"@ at--- all (v3 has no valid shape for it yet), is still refused.-checkedFromJson :: Mode -> Value -> Either EvalError Value'-checkedFromJson _ Null = Right VNull-checkedFromJson _ (Bool b) = Right (VBool b)-checkedFromJson _ (Number n) = Right (VNumber n)-checkedFromJson _ (String s) = Right (VString s)-checkedFromJson mode (Array arr) = VArray <$> traverse (checkedFromJson mode) (V.toList arr)-checkedFromJson mode (Object obj)-  | KeyMap.member (Key.fromText "$type") obj =-      Left (TypeMismatch "the context carries the reserved key \"$type\", which only a typed envelope may use")-  | Just symVal <- KeyMap.lookup (Key.fromText "$sym") obj =-      case mode of-        Concrete -> Left (TypeMismatch "the context carries the reserved key \"$sym\", which only a symbolic envelope may use")-        Symbolic -> case (symVal, KeyMap.toList (KeyMap.delete (Key.fromText "$sym") obj)) of-          (String sid, [("path", Array pathArr)]) -> do-            path <- traverse expectString (V.toList pathArr)-            Right (VSymbol sid path)-          _ -> Left (TypeMismatch "a \"$sym\" object must be exactly {\"$sym\": <id>, \"path\": [<segment>, ...]}")-  | otherwise =-      VObject . Map.fromList <$> traverse (\(k, v) -> (,) (Key.toText k) <$> checkedFromJson mode v) (KeyMap.toList obj)+-- | The input context's boundary. It is decoded whole, before evaluation+-- starts, so what it refuses does not depend on what the program reads, and+-- every refusal is a 'TypeMismatch'.+--+-- Numbers first (reference.md \S3): a JSON number is read as the literal of+-- the same text, so @3@ is an integer and @3.0@ a float, and one the value+-- domain does not hold is refused or normalized by+-- 'Tramaj.Json.normalizeNumbers', which lists the cases.+--+-- Then the reserved keys: @"$sym"@, @"$type"@ and @"$term"@ are recursively+-- refused as ordinary object keys (v3-symbols \S5.3), in every profile. In+-- concrete mode each is refused unconditionally. In symbolic mode, seeding+-- (\S5.4) accepts a well-formed @{"$sym": ..., "path": [...]}@ back as an+-- actual symbol and, with the arithmetic profile on, a well-formed term back+-- as an actual term -- anything else carrying @"$sym"@ or @"$term"@, or+-- @"$type"@ at all (v3 has no valid shape for it yet), is still refused.+checkedFromJson :: Options -> Json -> Either EvalError Value'+checkedFromJson options input =+  first (\why -> TypeMismatch ("the context holds a number that is not a value: " <> T.pack why)) (normalizeNumbers input) >>= decode   where-    expectString (String s) = Right s+    decode (JArray xs) = VArray <$> traverse decode xs+    decode (JObject obj)+      | Map.member "$type" obj =+          Left (TypeMismatch "the context carries the reserved key \"$type\", which only a typed envelope may use")+      | Just symVal <- Map.lookup "$sym" obj =+          case optMode options of+            Concrete -> Left (TypeMismatch "the context carries the reserved key \"$sym\", which only a symbolic envelope may use")+            Symbolic -> case (symVal, Map.toList (Map.delete "$sym" obj)) of+              (JString sid, [("path", JArray pathArr)]) -> do+                path <- traverse expectString pathArr+                Right (VSymbol sid path)+              _ -> Left (TypeMismatch "a \"$sym\" object must be exactly {\"$sym\": <id>, \"path\": [<segment>, ...]}")+      | Just opVal <- Map.lookup "$term" obj =+          case optMode options of+            Concrete -> Left (TypeMismatch "the context carries the reserved key \"$term\", which only a symbolic envelope may use")+            Symbolic -> case (opVal, Map.toList (Map.delete "$term" obj)) of+              (JString op, [("arguments", JArray args)]) -> traverse decode args >>= seededTerm op+              _ -> Left (TypeMismatch "a \"$term\" object must be exactly {\"$term\": <op>, \"arguments\": [<argument>, ...]}")+      | otherwise = VObject <$> traverse decode obj+    decode scalar = Right (fromJson scalar)++    -- A well-formed term is one a call could have built (\S5.3), so this is+    -- the call's own check, 'arithmeticOperands', on arguments already+    -- decoded, which holds a nested term to the same rule. Two things a call+    -- accepts are refused first: an array, since a term holds its operands+    -- already flattened, and operands that are all numbers, since the call+    -- would have computed. Without the arithmetic profile no @op@ is known,+    -- so every term is refused.+    seededTerm op args+      | not (optArithmetic options) = Left (TypeMismatch ("the context carries a term (" <> tshow op <> "), which needs the arithmetic profile"))+      | op `notElem` arithmeticNames = Left (TypeMismatch ("a term names an unknown operation: " <> tshow op))+      | any isArray args = Left (TypeMismatch ("a term (" <> tshow op <> ") holds its operands flattened, not in an array"))+      | otherwise = do+          operands <- arithmeticOperands op args+          if any isSymbolic operands+            then Right (VTerm op operands)+            else Left (TypeMismatch ("a term (" <> tshow op <> ") must hold a symbol or a term among its arguments"))++    isArray (VArray _) = True+    isArray _ = False++    expectString (JString 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 (VInt _) = "an integer"+describeValue (VFloat _) = "a float" describeValue (VString _) = "a string" describeValue (VArray _) = "an array" describeValue (VObject _) = "an object"@@ -1005,30 +1203,42 @@ describeValue (VImport pending) = "the not-yet-run import of " <> tshow (pName pending) describeValue (VConstraint name _) = "a constraint (" <> tshow name <> ")" describeValue (VSymbol _ _) = "a symbol"+describeValue (VTerm op _) = "a term (" <> tshow op <> ")"  -- | 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 (VTerm _ _) = 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+-- | Whether a value is itself a symbol or a term (v3-symbols \S1.9), which+-- is the depth at which a container, a collection, a condition or an operand+-- is refused: a concrete structure that merely holds one is not special+-- (\S1.7). 'containsSymbol' is the other depth.+isSymbolic :: Value' -> Bool+isSymbolic (VSymbol _ _) = True+isSymbolic (VTerm _ _) = True+isSymbolic _ = False++-- | Whether a value is, or contains, a symbol or a term -- 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 (VTerm _ _) = 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+-- | Requires a value with no symbol and no term 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 :: Text -> Value' -> Either EvalError Json requireConcrete who v   | containsSymbol v = Left (NotConcrete who)   | otherwise = toJson v@@ -1036,12 +1246,12 @@ -- | 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+-- injective. This is exactly 'stringify', which already quotes a string+-- unconditionally and sorts keys. It writes an integer and a float+-- differently (@1@ and @1.0@), which injectivity needs now that they are+-- two values.+canon :: Json -> Text+canon = stringify  tshow :: (Show a) => a -> Text tshow = T.pack . show@@ -1059,16 +1269,21 @@   "not" -> arity1 (fmap (VBool . not) . asBool)   "and" -> variadicBool (&&) True   "or" -> variadicBool (||) False+  -- No coercion across types: 'Json' equality never equates an integer+  -- with a float, so @eq(1, 1.0)@ is @false@, like @eq(1, "1")@.   "eq" -> binary (\a b -> VBool <$> ((==) <$> requireConcrete name a <*> requireConcrete name b))-  "lt" -> comparison (<)-  "lte" -> comparison (<=)-  "gt" -> comparison (>)-  "gte" -> comparison (>=)+  "lt" -> comparison (<) (<)+  "lte" -> comparison (<=) (<=)+  "gt" -> comparison (>) (>)+  "gte" -> comparison (>=) (>=)   "has" -> binary hasImpl   "lookup" -> ternary lookupImpl+  "format-number" -> ternary formatNumberImpl   "concat" -> concatImpl   "append" -> binary appendImpl-  _ -> Left (UnboundName name)+  _+    | name `elem` arithmeticNames -> arithmetic name args+    | otherwise -> Left (UnboundName name)   where     arity1 :: (Value' -> Either EvalError a) -> Either EvalError a     arity1 f = case args of@@ -1087,18 +1302,24 @@      cardinality :: Either EvalError Value'     cardinality = arity1 $ \case-      VArray xs -> Right (VNumber (fromIntegral (length xs)))-      VObject o -> Right (VNumber (fromIntegral (Map.size o)))+      VArray xs -> Right (VInt (fromIntegral (length xs)))+      VObject o -> Right (VInt (fromIntegral (Map.size o)))       VSymbol _ _ -> Left (NotConcrete name)+      VTerm _ _ -> 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+    -- | A number operand, returned as it is so that its type is still+    -- there to check. A symbol or a term is 'NotConcrete' (v3-symbols+    -- \S1.5).+    asNumber :: Value' -> Either EvalError Value'+    asNumber v@(VInt _) = Right v+    asNumber v@(VFloat _) = Right v     asNumber (VSymbol _ _) = Left (NotConcrete name)+    asNumber (VTerm _ _) = Left (NotConcrete name)     asNumber other = Left (TypeMismatch (name <> " expects a number argument, got " <> describeValue other))      asArray :: Value' -> Either EvalError [Value']@@ -1110,8 +1331,18 @@     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)+    -- | Two integers or two floats (reference.md \S11). A mixed pair is a+    -- 'TypeMismatch' like any other pair of two types: nothing is promoted,+    -- so @gt(1.5, 0)@ is written @gt(1.5, 0.0)@. The operator is passed+    -- once per type because each pair is compared in its own domain.+    comparison :: (Int64 -> Int64 -> Bool) -> (Double -> Double -> Bool) -> Either EvalError Value'+    comparison opInt opFloat = binary $ \a b -> do+      na <- asNumber a+      nb <- asNumber b+      case (na, nb) of+        (VInt x, VInt y) -> Right (VBool (opInt x y))+        (VFloat x, VFloat y) -> Right (VBool (opFloat x y))+        _ -> Left (TypeMismatch (name <> " expects two integers or two floats, got " <> describeValue na <> " and " <> describeValue nb))      -- | Deliberately tolerant: a missing key, an out-of-range index, or a     -- container of the wrong shape all answer @false@ rather than erroring@@ -1120,9 +1351,10 @@     -- something about a container the language cannot see into.     hasImpl :: Value' -> Value' -> Either EvalError Value'     hasImpl (VSymbol _ _) _ = Left (NotConcrete name)+    hasImpl (VTerm _ _) _ = 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)+      (VArray xs, VInt n) -> maybe False (\i -> i < length xs) (asIndex n)       _ -> False      -- | Dynamic access by a computed key or index -- the counterpart to a@@ -1131,23 +1363,49 @@     -- would silently discard the symbol (\S1.5).     lookupImpl :: Value' -> Value' -> Value' -> Either EvalError Value'     lookupImpl (VSymbol _ _) _ _ = Left (NotConcrete name)+    lookupImpl (VTerm _ _) _ _ = 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)+      (VArray xs, VInt n) -> maybe fallback id (asIndex n >>= atIndex xs)       _ -> fallback +    -- | @format-number(x, decimals, group)@ (reference.md \S11, /Number+    -- formatting/). The arguments are examined left to right and the first+    -- that is not acceptable decides the error: a symbol or a term is+    -- 'NotConcrete', anything else of the wrong type a 'TypeMismatch'.+    formatNumberImpl :: Value' -> Value' -> Value' -> Either EvalError Value'+    formatNumberImpl x decimals group = do+      v <- case x of+        VInt n -> Right (toRational n)+        -- Exact: a double is a binary fraction, and this is its value.+        VFloat d -> Right (toRational d)+        other -> refuse "a number as its first argument" other+      places <- case decimals of+        VInt n | n >= 0 && n <= 20 -> Right (fromIntegral n :: Int)+        VInt n -> Left (TypeMismatch (name <> " expects a number of decimals from 0 to 20, got " <> tshow n))+        other -> refuse "an integer number of decimals" other+      separator <- case group of+        VString s -> Right s+        other -> refuse "a string as its separator" other+      Right (VString (formatNumber v places separator))+      where+        refuse :: Text -> Value' -> Either EvalError a+        refuse wanted other+          | isSymbolic other = Left (NotConcrete name)+          | otherwise = Left (TypeMismatch (name <> " expects " <> wanted <> ", got " <> describeValue other))+     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+    -- | An index must be a non-negative integer: @-1@ is not an index, and+    -- neither is a float, @1.0@ included, since nothing converts a float+    -- into an integer here.+    asIndex :: Int64 -> Maybe Int+    asIndex n+      | n >= 0 && n <= fromIntegral (maxBound :: Int) = Just (fromIntegral n)+      | otherwise = Nothing      -- | Variadic array join, preserving order. @concat()@ is @[]@; a     -- non-array argument anywhere is an error rather than being wrapped.@@ -1159,80 +1417,197 @@     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+-- Arithmetic (reference.md \S11) ---------------------------------------------------------------- --- | Compact JSON, with object keys in sorted order and numbers formatted by--- 'formatNumber'.+-- | One of the ten arithmetic builtins, applied. Operands that are all+-- numbers compute; if one is a symbol or a term the result is a term holding+-- the flattened operands exactly as written (v3-symbols \S1.9). Every+-- operand is checked before either happens, so a 'TypeMismatch' takes+-- precedence over a 'NotRepresentable'.+arithmetic :: Text -> [Value'] -> Either EvalError Value'+arithmetic name args = do+  operands <- arithmeticOperands name args+  if any isSymbolic operands then Right (VTerm name operands) else compute name operands++-- | The operands of a call, checked as far as they can be without knowing+-- what a symbol stands for; every refusal is a 'TypeMismatch'. ----- 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)))) <> "}"+-- * @sum@ and @product@ flatten their arguments by the rule children use:+--   an array contributes each of its elements, recursively, in order. They+--   need at least one operand afterwards. The eight others take a fixed+--   count and do not flatten, so an array given to one is refused whatever+--   it holds.+-- * Each operand is a number, a symbol or a term. A symbol or a term stands+--   for one number of either type and is not looked into.+-- * The operands that are numbers agree with each other in type and with+--   what the builtin accepts. Nothing is converted or promoted.+arithmeticOperands :: Text -> [Value'] -> Either EvalError [Value']+arithmeticOperands name args = do+  operands <- shape+  traverse_ requireOperand operands+  let numbers = filter (not . isSymbolic) operands+  if accepted numbers+    then Right operands+    else Left (TypeMismatch (name <> " expects " <> wanted <> ", got " <> T.intercalate ", " (map describeValue numbers)))   where-    entry (k, v) = quoteString k <> ":" <> compactJson v+    shape+      | variadic = case flatten args of+          [] -> Left (TypeMismatch (name <> " expects at least one operand: seed it with the zero or the one of the intended type"))+          operands -> Right operands+      | length args == arity = Right args+      | otherwise = Left (TypeMismatch (name <> " expects exactly " <> tshow arity <> " argument(s), got " <> tshow (length args))) --- | 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+    variadic = name `elem` (["sum", "product"] :: [Text]) -formatNumber :: Scientific -> Text-formatNumber = formatDouble . toRealFloat+    arity :: Int+    arity = if name `elem` (["quotient", "floor-quotient", "modulo"] :: [Text]) then 2 else 1 --- | Formats a double exactly as ECMAScript's @Number::toString@ does.+    flatten = concatMap $ \case+      VArray xs -> flatten xs+      other -> [other]++    requireOperand v+      | isInt v || isFloat v || isSymbolic v = Right ()+      | otherwise = Left (TypeMismatch (name <> " expects number operands, got " <> describeValue v))++    isInt (VInt _) = True+    isInt _ = False++    isFloat (VFloat _) = True+    isFloat _ = False++    accepted numbers = case name of+      "quotient" -> all isFloat numbers+      "inverse" -> all isFloat numbers+      "floor-quotient" -> all isInt numbers+      "modulo" -> all isInt numbers+      "sum" -> all isInt numbers || all isFloat numbers+      "product" -> all isInt numbers || all isFloat numbers+      -- @negate@, @floor@, @real@ and @round@ take a number of either type.+      _ -> True++    wanted :: Text+    wanted = case name of+      "quotient" -> "two floats"+      "inverse" -> "a float"+      "floor-quotient" -> "two integers"+      "modulo" -> "two integers"+      _ -> "all integers or all floats"++-- | The concrete rules (reference.md \S11, /Semantics/), over operands+-- 'arithmeticOperands' accepted and that are all numbers. ----- 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.+-- An integer result is computed over the unbounded 'Integer' and then held+-- to the signed 64-bit range, at every step of a fold: nothing is ever+-- computed in an 'Int64', whose own operators wrap. ----- 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+-- A float result is one 'Double' operation at a time, which GHC compiles+-- to the one IEEE 754 binary64 instruction, correctly rounded to nearest,+-- ties to even. It never contracts a product and a sum into a fused+-- multiply-add; that takes a primop this module does not use.+compute :: Text -> [Value'] -> Either EvalError Value'+compute name operands = case (name, operands) of+  ("sum", _) -> leftFold (+) (+)+  ("product", _) -> leftFold (*) (*)+  ("negate", [VInt x]) -> VInt <$> integer (negate (toInteger x))+  ("negate", [VFloat x]) -> VFloat <$> float (negate x)+  ("quotient", [VFloat a, VFloat b]) -> VFloat <$> float (a / b)+  ("inverse", [VFloat x]) -> VFloat <$> float (1 / x)+  -- 'div' rounds toward negative infinity and 'mod' is its remainder, zero+  -- or of the sign of the divisor, which is what \S11 asks of the two. Each+  -- is checked on its own: the remainder of @-2^63@ by @-1@ is @0@, although+  -- the quotient is out of range.+  ("floor-quotient", [VInt a, VInt b]) -> VInt <$> (nonZero b *> integer (toInteger a `div` toInteger b))+  ("modulo", [VInt a, VInt b]) -> VInt <$> (nonZero b *> integer (toInteger a `mod` toInteger b))+  ("floor", [VInt x]) -> Right (VInt x)+  ("floor", [VFloat x]) -> VInt <$> integer (floor x)+  -- The double nearest to the integer, ties to even: exact up to @2^53@,+  -- rounded beyond. This is the machine's own conversion.+  ("real", [VInt x]) -> Right (VFloat (fromIntegral x))+  ("real", [VFloat x]) -> Right (VFloat x)+  -- The integer nearest to the exact value of the float, a tie going away+  -- from zero: the rule 'formatNumber' applies to no decimals.+  ("round", [VInt x]) -> Right (VInt x)+  ("round", [VFloat x]) -> VInt <$> integer (roundHalfAway (toRational x))+  _ -> mismatch+  where+    mismatch :: Either EvalError a+    mismatch = Left (TypeMismatch (name <> " cannot be applied to " <> T.intercalate ", " (map describeValue operands))) --- | 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)+    -- A left fold from the first operand, each step checked: an integer+    -- step out of range is an error although the total would be in range.+    leftFold :: (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> Either EvalError Value'+    leftFold opInt opFloat = case operands of+      VInt x : rest -> VInt <$> foldM intStep x rest+      VFloat x : rest -> VFloat <$> foldM floatStep x rest+      _ -> mismatch+      where+        intStep acc (VInt y) = integer (opInt (toInteger acc) (toInteger y))+        intStep _ _ = mismatch+        floatStep acc (VFloat y) = float (opFloat acc y)+        floatStep _ _ = mismatch++    -- An integer result, or 'NotRepresentable' outside the integer range.+    integer :: Integer -> Either EvalError Int64+    integer n+      | inIntegerRange n = Right (fromInteger n)+      | otherwise = Left (NotRepresentable (name <> ": the result is outside the integer range, -2^63 to 2^63 - 1"))++    -- A float result, or 'NotRepresentable' when it is not finite, which+    -- covers overflow and a zero divisor alike. There is no negative zero.+    float :: Double -> Either EvalError Double+    float d+      | isNaN d || isInfinite d = Left (NotRepresentable (name <> ": the result is not a finite float"))+      | d == 0 = Right 0+      | otherwise = Right d++    nonZero :: Int64 -> Either EvalError ()+    nonZero 0 = Left (NotRepresentable (name <> ": the divisor is zero"))+    nonZero _ = Right ()++-- Number formatting (reference.md \S11) ---------------------------------------------------------++-- | The integer nearest to an exact value; when two are equally near, the+-- one farther from zero. This is the one rounding rule of @round@ and+-- @format-number@, written out over 'Rational' because no native formatter+-- or 'round' (which takes a tie to even) follows it.+roundHalfAway :: Rational -> Integer+roundHalfAway v+  | v < 0 = negate (roundHalfAway (negate v))+  | otherwise = floor (v + 1 / 2)++-- | An exact value in positional decimal notation: an optional @-@, the+-- integer part with the separator between its groups of three digits+-- counted from the point leftward, and, when there are decimals, a @.@ and+-- exactly that many digits. Never an exponent, and no sign on a result+-- whose digits are all zero.+formatNumber :: Rational -> Int -> Text -> Text+formatNumber v places separator =+  (if scaled < 0 then "-" else "") <> grouped <> (if places == 0 then "" else "." <> fractionPart)   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+    -- The value in units of the last digit asked for, rounded.+    scaled :: Integer+    scaled = roundHalfAway (v * 10 ^ places)++    -- At least one digit before the point: @0.50@, never @.50@.+    digits :: Text+    digits = T.justifyRight (places + 1) '0' (T.pack (show (abs scaled)))++    (integerPart, fractionPart) = T.splitAt (T.length digits - places) digits++    grouped :: Text+    grouped+      | T.null separator = integerPart+      | otherwise = T.intercalate separator (reverse (map T.reverse (T.chunksOf 3 (T.reverse integerPart))))++-- | 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 :: Json -> Text+displayString JNull = ""+displayString (JString s) = s+displayString other = stringify other

@@ -0,0 +1,275 @@+-- | JSON as Tramaj reads and writes it: like any JSON value, except that a+-- number is an integer or a float, decided by its text (@reference.md@ \S3,+-- @node-json.md@ /Numbers/, @decisions.md@ \S18).+--+-- This module exists because aeson's 'Aeson.Value' cannot carry that+-- difference: it holds every number as a 'Scientific', where @3@, @3.0@ and+-- @3e0@ are one value, and its encoder writes all three as @3@. Everything+-- Tramaj takes in or hands out as JSON (the context, a @Node@'s payloads, an+-- expression program's result, the symbolic envelope) is therefore this+-- 'Json', read by 'jsonParser' and written by 'stringify'.+--+-- 'fromAeson' and 'toAeson' bridge to an aeson value, and say what each+-- direction costs.+--+-- __Integer range.__ This implementation has the signed 64-bit range,+-- @-2^63@ to @2^63 - 1@ (@reference.md@ \S13): the evaluator holds an integer+-- in an 'Int64'.+module Tramaj.Json+  ( Json (..)++    -- * Reading and writing+  , jsonParser+  , stringify+  , formatInteger+  , formatFloat+  , quoteString++    -- * The number rules of a decoding boundary+  , minInteger+  , maxInteger+  , inIntegerRange+  , normalizeInteger+  , normalizeFloat+  , normalizeNumbers++    -- * Bridging to aeson+  , fromAeson+  , toAeson+  ) where++import qualified Data.Aeson as Aeson+import Data.Aeson.Decoding.Text (textToTokens)+import Data.Aeson.Decoding.Tokens (Lit (..), Number (..), TkArray (..), TkRecord (..), Tokens (..))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Char (intToDigit)+import Data.Int (Int64)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Scientific (fromFloatDigits, toBoundedInteger, toRealFloat)+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)++-- | A JSON value whose numbers keep their type.+--+-- A value Tramaj produced always holds a 'JInt' inside the integer range and+-- a 'JFloat' that is finite and not a negative zero. 'jsonParser' is more+-- lenient on purpose, so that refusing a number is left to whoever decodes+-- the value (see 'normalizeNumbers'): it reads an integer-form number of any+-- size exactly, which is why 'JInt' holds an 'Integer', and a float too+-- large for a double as an infinity.+--+-- Equality is structural, with object keys unordered. An integer and a float+-- are never equal, whatever they hold: @3@ and @3.0@ are two values.+data Json+  = JNull+  | JBool Bool+  | JInt Integer+  | JFloat Double+  | JString Text+  | JArray [Json]+  | JObject (Map Text Json)+  deriving stock (Eq, Show)++-- Reading -------------------------------------------------------------------++-- | Reads JSON text, typing each number by its text (@reference.md@ \S3): one+-- with neither a fraction nor an exponent is a 'JInt', one with either is a+-- 'JFloat', so @3@ is an integer and @3.0@ and @3e0@ are floats.+--+-- No number is refused here. An integer keeps every digit, and a float is the+-- double nearest to its decimal value, which is an infinity when the value is+-- too large for a double; 'normalizeNumbers' is what refuses.+--+-- The tokens come from aeson's own decoder, which is the layer that still+-- knows which of the three forms a number was written in; 'Aeson.Value' is+-- one step too late.+jsonParser :: Text -> Either String Json+jsonParser src = value (textToTokens src) $ \v rest ->+  if T.all isJsonSpace rest+    then Right v+    else Left "Unexpected trailing input after the JSON value"+  where+    isJsonSpace c = c == ' ' || c == '\n' || c == '\r' || c == '\t'++value :: Tokens k String -> (Json -> k -> Either String r) -> Either String r+value (TkLit LitNull k) kont = kont JNull k+value (TkLit LitTrue k) kont = kont (JBool True) k+value (TkLit LitFalse k) kont = kont (JBool False) k+value (TkText t k) kont = kont (JString t) k+value (TkNumber n k) kont = kont (number n) k+value (TkArrayOpen items) kont = array [] items kont+value (TkRecordOpen pairs) kont = record [] pairs kont+value (TkErr e) _ = Left e++array :: [Json] -> TkArray k String -> (Json -> k -> Either String r) -> Either String r+array acc (TkItem tokens) kont = value tokens (\v rest -> array (v : acc) rest kont)+array acc (TkArrayEnd k) kont = kont (JArray (reverse acc)) k+array _ (TkArrayErr e) _ = Left e++-- | A repeated key keeps its last value, as aeson's own decoder does.+record :: [(Text, Json)] -> TkRecord k String -> (Json -> k -> Either String r) -> Either String r+record acc (TkPair key tokens) kont = value tokens (\v rest -> record ((Key.toText key, v) : acc) rest kont)+record acc (TkRecordEnd k) kont = kont (JObject (Map.fromList (reverse acc))) k+record _ (TkRecordErr e) _ = Left e++number :: Number -> Json+number (NumInteger n) = JInt n+number (NumDecimal s) = JFloat (toRealFloat s)+number (NumScientific s) = JFloat (toRealFloat s)++-- Writing -------------------------------------------------------------------++-- | Compact JSON, with object keys in sorted order and a number written by+-- its type (@node-json.md@, /Numbers/): an integer as its digits, a float+-- always with a fraction or an exponent.+--+-- This is also @str@'s rendering of an array or an object and v3-symbols+-- \S1.4's canon, which is why the key order is fixed: object key order is+-- not semantically significant, so it must not be observable there.+stringify :: Json -> Text+stringify JNull = "null"+stringify (JBool b) = if b then "true" else "false"+stringify (JInt n) = formatInteger n+stringify (JFloat d) = formatFloat d+stringify (JString s) = quoteString s+stringify (JArray xs) = "[" <> T.intercalate "," (map stringify xs) <> "]"+stringify (JObject o) = "{" <> T.intercalate "," (map entry (Map.toAscList o)) <> "}"+  where+    entry (k, v) = quoteString k <> ":" <> stringify 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 . Aeson.encode . Aeson.String++-- | An integer as its decimal digits, with a @-@ when negative: no fraction+-- and no exponent, whatever its size.+formatInteger :: Integer -> Text+formatInteger = T.pack . show++-- | A float as the shortest round-trip text of ECMAScript's+-- @Number::toString@, with @.0@ appended when that text has neither a+-- fraction nor an exponent: @1.0@, @0.1@, @100000000000.0@, @1e+21@,+-- @1e-7@. A float therefore never reads back as an integer.+formatFloat :: Double -> Text+formatFloat d+  | isNaN d || isInfinite d = shortest+  | T.any (\c -> c == '.' || c == 'e') shortest = shortest+  | otherwise = shortest <> ".0"+  where+    shortest = formatDouble d++-- | 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.+--+-- NaN and infinities are not values (@reference.md@ \S3); they are written+-- as ECMAScript names them only so that a 'Json' nobody normalized still+-- shows what it holds.+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 <> T.pack (show (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++-- The number rules of a decoding boundary ------------------------------------++-- | The bottom of this implementation's integer range, @-2^63@.+minInteger :: Integer+minInteger = toInteger (minBound :: Int64)++-- | The top of this implementation's integer range, @2^63 - 1@.+maxInteger :: Integer+maxInteger = toInteger (maxBound :: Int64)++inIntegerRange :: Integer -> Bool+inIntegerRange n = n >= minInteger && n <= maxInteger++-- | An integer-form number as the value it denotes: one outside the integer+-- range is refused, never rounded (@reference.md@ \S3, \S13).+normalizeInteger :: Integer -> Either String Int64+normalizeInteger n+  | inIntegerRange n = Right (fromInteger n)+  | otherwise = Left ("the integer " <> show n <> " is outside the signed 64-bit range")++-- | A float-form number as the value it denotes. One too large for a double+-- is refused, as the literal @1e400@ is a parse error; a negative zero is+-- zero, as the literal @-0.0@ evaluates to @0.0@.+normalizeFloat :: Double -> Either String Double+normalizeFloat d+  | isNaN d || isInfinite d = Left "a float is too large for a double"+  | d == 0 = Right 0+  | otherwise = Right d++-- | What a decoder does to the numbers of a JSON value it is about to treat+-- as a Tramaj value, at any depth: 'normalizeInteger' for each integer and+-- 'normalizeFloat' for each float. The context decoder and+-- 'Tramaj.Node.nodeFromJson' both go through here, so these three functions+-- are the one place that decides which numbers a boundary refuses and which+-- it rewrites.+normalizeNumbers :: Json -> Either String Json+normalizeNumbers (JInt n) = JInt . toInteger <$> normalizeInteger n+normalizeNumbers (JFloat d) = JFloat <$> normalizeFloat d+normalizeNumbers (JArray xs) = JArray <$> traverse normalizeNumbers xs+normalizeNumbers (JObject o) = JObject <$> traverse normalizeNumbers o+normalizeNumbers scalar = Right scalar++-- Bridging to aeson ----------------------------------------------------------++-- | From an aeson value, which has one number type and so cannot say which+-- of the two a number is. A whole number in the integer range becomes an+-- integer and any other number a float, so a host that means the float+-- @3.0@ must build a 'JFloat' itself, or read its JSON text with+-- 'jsonParser' instead of aeson's decoder.+fromAeson :: Aeson.Value -> Json+fromAeson Aeson.Null = JNull+fromAeson (Aeson.Bool b) = JBool b+fromAeson (Aeson.Number s) = case toBoundedInteger s :: Maybe Int64 of+  Just n -> JInt (toInteger n)+  Nothing -> JFloat (toRealFloat s)+fromAeson (Aeson.String s) = JString s+fromAeson (Aeson.Array xs) = JArray (map fromAeson (V.toList xs))+fromAeson (Aeson.Object o) = JObject (Map.fromList (map (\(k, v) -> (Key.toText k, fromAeson v)) (KeyMap.toList o)))++-- | To an aeson value, giving the number type up: @1@ and @1.0@ become the+-- same 'Aeson.Number', and aeson's encoder writes both as @1@. Use+-- 'stringify' to write a value whose numbers must keep their type.+toAeson :: Json -> Aeson.Value+toAeson JNull = Aeson.Null+toAeson (JBool b) = Aeson.Bool b+toAeson (JInt n) = Aeson.Number (fromInteger n)+toAeson (JFloat d) = Aeson.Number (fromFloatDigits d)+toAeson (JString s) = Aeson.String s+toAeson (JArray xs) = Aeson.Array (V.fromList (map toAeson xs))+toAeson (JObject o) = Aeson.Object (KeyMap.fromList (map (\(k, v) -> (Key.fromText k, toAeson v)) (Map.toList o)))

@@ -18,20 +18,18 @@   , mapActions   ) where -import Data.Aeson (Value (..), object, (.=))-import qualified Data.Aeson.Key as Key-import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bifunctor (first) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text)-import qualified Data.Vector as V+import Tramaj.Json (Json (..), normalizeNumbers)  -- | 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+type Annotations = Map Text Json  noAnnotations :: Annotations noAnnotations = Map.empty@@ -39,14 +37,15 @@ -- | 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+-- 'NText' holds a 'Json' value, not a 'Text': @.p($ctx.count)@ with+-- @count = 3@ keeps the integer @3@ rather than stringifying it, and the+-- float @3.0@ stays a float (@../specs/node-json.md@, /Numbers/). 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+-- value); it is 'JNull' 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. --@@ -54,8 +53,8 @@ -- wrapper element. A host may flatten fragments when folding; evaluation -- does not. data Node-  = NText Value Annotations-  | NElement Text [NodeAttribute] Value [Node] Annotations+  = NText Json Annotations+  | NElement Text [NodeAttribute] Json [Node] Annotations   | NFragment [Node] Annotations   deriving stock (Eq, Show) @@ -63,8 +62,8 @@ -- @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+  = NAttr Text Json+  | NAction Text Text Json   deriving stock (Eq, Show)  -- Serialization -----------------------------------------------------------@@ -73,51 +72,57 @@ -- 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 :: Node -> Json nodeToJson (NText v anns) =-  object ["type" .= ("text" :: Text), "value" .= v, "annotations" .= annotationsToJson anns]+  object [("type", JString "text"), ("value", v), ("annotations", JObject 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+    [ ("type", JString "element")+    , ("tag", JString tag)+    , ("attributes", JArray (map nodeAttributeToJson attrs))+    , ("value", val)+    , ("children", JArray (map nodeToJson children))+    , ("annotations", JObject anns)     ] nodeToJson (NFragment children anns) =   object-    [ "type" .= ("fragment" :: Text)-    , "children" .= V.fromList (map nodeToJson children)-    , "annotations" .= annotationsToJson anns+    [ ("type", JString "fragment")+    , ("children", JArray (map nodeToJson children))+    , ("annotations", JObject anns)     ] -nodeAttributeToJson :: NodeAttribute -> Value+nodeAttributeToJson :: NodeAttribute -> Json nodeAttributeToJson (NAttr name val) =-  object ["kind" .= ("attribute" :: Text), "name" .= name, "value" .= val]+  object [("kind", JString "attribute"), ("name", JString name), ("value", val)] nodeAttributeToJson (NAction event key payload) =-  object ["kind" .= ("action" :: Text), "event" .= event, "key" .= key, "payload" .= payload]+  object [("kind", JString "action"), ("event", JString event), ("key", JString key), ("payload", payload)] -annotationsToJson :: Annotations -> Value-annotationsToJson = Object . KeyMap.fromList . map (\(k, v) -> (Key.fromText k, v)) . Map.toList+object :: [(Text, Json)] -> Json+object = JObject . Map.fromList  -- | 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+--+-- A number in a @Value@ follows /Numbers/ and /Decoding/ there: an+-- integer-form number outside the integer range or a float too large for a+-- double is refused rather than rounded, at any depth, and a negative zero+-- decodes as zero ('reqValue'). Annotations are arbitrary JSON, not a+-- @Value@, and are kept as they were read.+nodeFromJson :: Json -> Either String Node+nodeFromJson (JObject obj) = do   ty <- reqString "node" "type" obj   case ty of     "text" -> do-      v <- req "text node" "value" obj+      v <- reqValue "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+      val <- reqValue "element node" "value" obj       children <- reqArray "element node" "children" obj >>= traverse nodeFromJson       anns <- reqAnnotations obj       pure (NElement tag attrs val children anns)@@ -128,40 +133,46 @@     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+nodeAttributeFromJson :: Json -> Either String NodeAttribute+nodeAttributeFromJson (JObject obj) = do   kind <- reqString "node attribute" "kind" obj   case kind of-    "attribute" -> NAttr <$> reqString "attribute" "name" obj <*> req "attribute" "value" obj+    "attribute" -> NAttr <$> reqString "attribute" "name" obj <*> reqValue "attribute" "value" obj     "action" ->       NAction         <$> reqString "action" "event" obj         <*> reqString "action" "key" obj-        <*> req "action" "payload" obj+        <*> reqValue "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+req :: String -> Text -> Map Text Json -> Either String Json+req what field obj = case Map.lookup field obj of   Nothing -> Left (what <> ": missing required field " <> show field)   Just v -> Right v -reqString :: String -> Text -> KeyMap.KeyMap Value -> Either String Text+-- | A field holding a @Value@, with its numbers checked ('normalizeNumbers').+reqValue :: String -> Text -> Map Text Json -> Either String Json+reqValue what field obj = do+  v <- req what field obj+  first (\why -> what <> ": field " <> show field <> ": " <> why) (normalizeNumbers v)++reqString :: String -> Text -> Map Text Json -> Either String Text reqString what field obj =   req what field obj >>= \case-    String s -> Right s+    JString s -> Right s     _ -> Left (what <> ": field " <> show field <> " must be a string") -reqArray :: String -> Text -> KeyMap.KeyMap Value -> Either String [Value]+reqArray :: String -> Text -> Map Text Json -> Either String [Json] reqArray what field obj =   req what field obj >>= \case-    Array arr -> Right (V.toList arr)+    JArray arr -> Right arr     _ -> Left (what <> ": field " <> show field <> " must be an array") -reqAnnotations :: KeyMap.KeyMap Value -> Either String Annotations+reqAnnotations :: Map Text Json -> 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)))+    JObject anns -> Right anns     _ -> Left "node: field \"annotations\" must be an object"  -- Transformation -----------------------------------------------------------@@ -172,7 +183,7 @@ -- 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 :: (Applicative f) => (Text -> Text -> Json -> 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

@@ -33,6 +33,7 @@   ) where  import Data.Char (chr, isAlphaNum, isDigit, isHexDigit, isLetter)+import Data.Int (Int64) import Data.List (nub) import Data.Maybe (fromMaybe) import Data.Text (Text)@@ -220,9 +221,14 @@ -- 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.+-- the exponent's sign normalized before the text is read.+--+-- The form decides the type (\S5, decisions \S18). With neither a fraction+-- nor an exponent the literal is an integer, denoting exactly its value, and+-- one outside the signed 64-bit range is refused; the sign is part of the+-- literal, so @-9223372036854775808@ is in range. With either it is a float:+-- an overflow to infinity is refused and a zero is normalized so @-0.0@+-- never escapes. numberLit :: P Expr numberLit = lexeme $ try $ do   sign <- optional (char '-')@@ -238,12 +244,19 @@           <> 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)+  case (fracPart, expPart) of+    (Nothing, Nothing) -> case reads (T.unpack fullStr) :: [(Integer, String)] of+      [(n, "")]+        | n < toInteger (minBound :: Int64) || n > toInteger (maxBound :: Int64) ->+            fail ("integer literal outside the signed 64-bit range: " <> T.unpack fullStr)+        | otherwise -> pure (IntLit (fromInteger n))+      _ -> fail ("invalid number literal: " <> T.unpack fullStr)+    _ -> case reads (T.unpack fullStr) :: [(Double, String)] of+      [(n, "")]+        | isInfinite n -> fail ("number literal out of range: " <> T.unpack fullStr)+        | n == 0 -> pure (FloatLit 0)+        | otherwise -> pure (FloatLit n)+      _ -> fail ("invalid number literal: " <> T.unpack fullStr)   where     digits = do       first <- takeWhile1P (Just "digit") isDigit@@ -297,14 +310,15 @@ 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.+-- | @"$sym"@, @"$type"@ and @"$term"@ 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 one of them as a key is a parse error in every profile, not just+-- the symbolic or the arithmetic one, so a program's legality never depends+-- on which profile runs it. reservedKeyRefused :: Text -> P () reservedKeyRefused k-  | k `elem` (["$sym", "$type"] :: [Text]) =+  | k `elem` (["$sym", "$type", "$term"] :: [Text]) =       fail ("\"" <> T.unpack k <> "\" is a reserved key and cannot be used as an object key")   | otherwise = pure () @@ -450,7 +464,7 @@   name <- try $ do     _ <- optional (char '$')     n <- identifier-    if n `elem` (["map", "filter", "scan", "fold", "branch", "import", "adapt-actions", "constraint"] :: [Text])+    if n `elem` (["map", "filter", "scan", "fold", "sort-by", "sort-by-descending", "branch", "import", "adapt-actions", "constraint"] :: [Text])       then pure n       else fail "not a special form"   base <- case name of@@ -458,6 +472,8 @@     "filter" -> binaryShape Filter     "scan" -> ternaryShape Scan     "fold" -> ternaryShape Fold+    "sort-by" -> binaryShape (SortBy False)+    "sort-by-descending" -> binaryShape (SortBy True)     "branch" -> branchShape     "import" -> importShape     "adapt-actions" -> adaptActionsShape@@ -604,11 +620,13 @@  -- Types --------------------------------------------------------------------- --- | The five value-domain shapes v4-types \S1 reserves as type primitives.+-- | The six 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.+-- resolution pass to classify. @int@ and @float@ are the value domain's two+-- number types; @number@ is no longer a primitive, so it parses as an+-- ordinary name and resolves only if a program declares it. primNames :: [Text]-primNames = ["string", "number", "bool", "null", "document"]+primNames = ["string", "int", "float", "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@@ -742,7 +760,8 @@         <|> (asScalar <$> keywordLit)      asScalar :: Expr -> TypeConstraintArg-    asScalar (NumberLit n) = TCScalarNum n+    asScalar (IntLit n) = TCScalarInt n+    asScalar (FloatLit n) = TCScalarFloat n     asScalar (BoolLit b) = TCScalarBool b     asScalar NullLit = TCScalarNull     asScalar (StringLit s) = TCScalarStr s

@@ -65,6 +65,7 @@   , programTypeRoots   ) where +import Data.Int (Int64) import Data.List (sortOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -394,7 +395,8 @@     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@(IntLit _) = pure e+    go e@(FloatLit _) = pure e     go e@(BoolLit _) = pure e     go NullLit = pure NullLit     go (ArrayLit elems) = ArrayLit <$> traverse go elems@@ -407,6 +409,7 @@     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 (SortBy descending coll fn) = SortBy descending <$> go coll <*> 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@@ -433,12 +436,13 @@ -- 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+-- scalar shapes \S5 allows, a number being an integer or a float -- the type-realm counterpart of the -- already-evaluated 'Value'' a v3 constraint's argument becomes. data ResolvedConstraintArg   = RCType ResolvedType   | RCScalarStr Text-  | RCScalarNum Double+  | RCScalarInt Int64+  | RCScalarFloat Double   | RCScalarBool Bool   | RCScalarNull   deriving stock (Eq, Ord, Show)@@ -446,7 +450,8 @@ 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 _ _ (TCScalarInt n) = Right (RCScalarInt n)+resolveConstraintArg _ _ (TCScalarFloat n) = Right (RCScalarFloat n) resolveConstraintArg _ _ (TCScalarBool b) = Right (RCScalarBool b) resolveConstraintArg _ _ TCScalarNull = Right RCScalarNull 

@@ -23,6 +23,8 @@   holeSpec   constraintSpec   symbolSpec+  arithmeticSpec+  sortSpec   typeParamSpec  prog :: Text -> Program@@ -36,6 +38,8 @@     , ("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)")+    , ("adds", prog "sum($ctx.a, 1)")+    , ("scales", prog "@f=(product) => $product\n.p(floor($ctx.x), import(\"adds\", {a: 1}).rendered)")     , ("typed", prog "!constraint(\"has-type\", $ctx, \"Deployment\")\n1")     ] @@ -198,7 +202,7 @@ 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"]+    typeDeclarations (prog "type A = string\ntype B = int\ntrue") `shouldBe` Set.fromList ["A", "B"]    it "is empty for a program with no type declaration" $     typeDeclarations (prog "1") `shouldBe` Set.empty@@ -224,3 +228,102 @@     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)]++-- | reference.md \S9: every analysis traverses a sort as it traverses a+-- @map@, through the collection and through the key function. The corpus+-- cannot state this for the analyses it has no case shape for, so each one+-- is checked here, under both names.+sortSpec :: Spec+sortSpec = describe "a sort" $ do+  it "has its collection and its key function read by contextReads" $ do+    contextReads (prog "sort-by($ctx.rows, (r) => lookup($r, $ctx.column, 0))")+      `shouldBe` Set.fromList [["rows"], ["column"]]+    contextReads (prog "sort-by-descending($ctx.rows, (r) => lookup($r, $ctx.column, 0))")+      `shouldBe` Set.fromList [["rows"], ["column"]]++  it "has a hole inside its key function reported by contextHoles" $+    contextHoles (prog "sort-by($ctx.rows, (r) => import(\"button\", {name: ctx(sort.label)}).vals.n)")+      `shouldBe` Set.fromList [["sort", "label"]]++  it "has an import inside its key function reported, and followed" $ do+    staticImportNames (prog "sort-by-descending(import(\"panel\", {}).vals.rows, (r) => import(\"row\", {}).vals.k)")+      `shouldBe` Set.fromList ["panel", "row"]+    transitiveImportNames libs (prog "sort-by([], (r) => import(\"row\", {}).vals.k)")+      `shouldBe` Set.fromList ["row", "button"]++  it "has an action key inside its key function reported" $ do+    staticActionKeys (prog "sort-by($ctx.rows, (r) => .b(action(\"on-click\", \"pick\", {})))")+      `shouldBe` Set.fromList ["pick"]+    deepActionKeys libs (prog "sort-by(import(\"row\", {}).rendered, (r) => .b(action(\"on-click\", \"pick\", {})))")+      `shouldBe` Set.fromList ["pick", "select", "deploy"]++  it "has an arithmetic name inside its key function reported, called or by reference" $ do+    arithmeticOps (prog "sort-by($ctx.rows, (r) => real($r.spend))") `shouldBe` Set.fromList ["real"]+    arithmeticOps (prog "sort-by-descending(map($ctx.xs, $negate), $round)") `shouldBe` Set.fromList ["negate", "round"]++  it "scopes the parameter of its key function, for arithmeticOps" $+    arithmeticOps (prog "[sort-by($ctx.xs, (floor) => $floor), sum(1, 2)]") `shouldBe` Set.fromList ["sum"]++  it "has a demand and an allocation inside its key function reported" $ do+    symbolDemands (prog "sort-by($ctx.rows, (r) => ?ctx.weight)") `shouldBe` Set.fromList [["weight"]]+    length (symbolSites (prog "sort-by($ctx.rows, (r) => ?($r.id))")) `shouldBe` 1++-- | reference.md \S9: which of the ten arithmetic names a program+-- references free. The shared corpus holds the same cases as+-- @"expect": "analysis"@ ones (@corpus/README.md@), which the PureScript+-- port runs too.+arithmeticSpec :: Spec+arithmeticSpec = describe "arithmetic operations" $ do+  it "names the ten builtins of the profile" $+    arithmeticNames+      `shouldBe` ["sum", "product", "negate", "inverse", "quotient", "floor-quotient", "modulo", "floor", "real", "round"]++  it "reports a name that is called" $+    arithmeticOps (prog "sum(1, negate($ctx.x))") `shouldBe` Set.fromList ["sum", "negate"]++  it "reports a name passed by reference" $+    arithmeticOps (prog "fold($ctx.xs, 0, $sum)") `shouldBe` Set.fromList ["sum"]++  it "reports every one of the ten" $+    arithmeticOps (prog "[$sum, $product, $negate, $inverse, $quotient, $floor-quotient, $modulo, $floor, $real, $round]")+      `shouldBe` Set.fromList arithmeticNames++  it "reports none in a program that uses none, whatever other builtin it calls" $+    arithmeticOps (prog "and(eq(1, 1), gt($ctx.n, 0))") `shouldBe` Set.empty++  it "does not report a name shadowed by a binding" $+    arithmeticOps (prog "@sum=(a, b) => $a\n$sum(1, 2)") `shouldBe` Set.empty++  it "reports a name used in the right-hand side of its own binding" $+    arithmeticOps (prog "@sum=sum(1, 2)\n$sum") `shouldBe` Set.fromList ["sum"]++  it "reports a name used before the binding that shadows it" $+    arithmeticOps (prog "@a=floor(1.5)\n@floor=1\n$floor") `shouldBe` Set.fromList ["floor"]++  it "does not report a name shadowed by a lambda parameter, inside that lambda only" $+    arithmeticOps (prog "[map($ctx.xs, (real) => $real), real(1)]") `shouldBe` Set.fromList ["real"]++  it "does not report a name shadowed by a pattern name" $+    arithmeticOps (prog "@{product, meta: {floor}} = $ctx.item\n[$product, $floor, modulo(1, 2)]")+      `shouldBe` Set.fromList ["modulo"]++  it "does not report a name shadowed by a lambda's pattern parameter" $+    arithmeticOps (prog "map($ctx.xs, ({sum}) => $sum)") `shouldBe` Set.empty++  it "reports a name under an arm no context will select" $+    arithmeticOps (prog "branch(1, false, inverse(0.0))") `shouldBe` Set.fromList ["inverse"]++  it "does not reach into a library on its own" $+    arithmeticOps (prog "import(\"adds\", {a: 1}).rendered") `shouldBe` Set.empty++  it "follows imports, directly or not, when deep" $+    deepArithmeticOps libs (prog "@x=negate(1)\nimport(\"scales\", {x: 1.5}).rendered")+      `shouldBe` Set.fromList ["negate", "floor", "sum"]++  it "gives a library its own scope: a binding of the importer shadows nothing there" $+    deepArithmeticOps libs (prog "@sum=1\nimport(\"adds\", {a: $sum}).rendered")+      `shouldBe` Set.fromList ["sum"]++  it "reports nothing for a missing library, and terminates on a cycle" $ do+    deepArithmeticOps libs (prog "import(\"absent\", {}).rendered") `shouldBe` Set.empty+    deepArithmeticOps libs (prog "import(\"loopy\", {}).rendered") `shouldBe` Set.empty

@@ -5,45 +5,122 @@ -- 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 Control.Monad (filterM, forM, forM_, when)+import Data.Aeson (FromJSON (..), eitherDecodeStrict, withObject, (.:), (.:?))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson (Parser)+import Data.Aeson.Types (parseEither) 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.Maybe (fromMaybe, isJust)+import Data.Set (Set)+import qualified Data.Set as Set 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.Analysis+  ( arithmeticOps+  , contextHoles+  , contextReads+  , deepActionKeys+  , deepArithmeticOps+  , deepContextHoles+  , staticActionKeys+  , staticImportNames+  , transitiveImportNames+  )+import Tramaj.Ast (Program)+import Tramaj.Eval (EvalError, LibraryTable, Mode (..), Options (..), defaultOptions, runProgramWith)+import Tramaj.Json (Json, jsonParser, stringify) 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+-- wholesale, via 'runProgramWith', which already reflects the mode and (once §4 -- lands) the kind in what it produces. data CaseMeta = CaseMeta   { metaName :: Text-  , metaMode :: Text+  , metaMode :: Maybe Text+  -- ^ Absent in an @"expect": "analysis"@ case, which evaluates nothing.   , metaExpect :: Text   , metaErrorKind :: Maybe Text+  , metaProfiles :: [Text]+  , metaHasRequires :: Bool+  -- ^ The key @profiles@ replaced. A case that still has it is refused+  -- rather than run without its gate.   }  instance FromJSON CaseMeta where   parseJSON = withObject "meta.json" $ \o ->-    CaseMeta <$> o .: "name" <*> o .: "mode"+    CaseMeta <$> o .: "name" <*> o .:? "mode"       <*> (fromMaybe "success" <$> o .:? "expect")       <*> o .:? "errorKind"+      <*> (fromMaybe [] <$> o .:? "profiles")+      <*> (isJust <$> (o .:? "requires" :: Aeson.Parser (Maybe Aeson.Value))) +-- | The profiles (@profiles@ in @meta.json@, see @corpus/README.md@) this+-- port can provide. A case naming any other one is skipped. @base@: the+-- language without any profile. @int-float@: integers and floats are two+-- types (a transition tag, not a profile). @int64@: an integer covers the+-- signed 64-bit range, so not @int53@. @arithmetic@: the arithmetic profile,+-- which is an option of each evaluation here ('optionsFromMeta'). @sort@,+-- @format-number@ and @round@: transition tags for the two sort forms, the+-- @format-number@ builtin and the tenth arithmetic name (decisions \S20).+providedProfiles :: [Text]+providedProfiles = ["base", "int-float", "int64", "arithmetic", "sort", "format-number", "round"]++-- | The profiles a case names that this port does not provide.+missingProfiles :: CaseMeta -> [Text]+missingProfiles = filter (`notElem` providedProfiles) . metaProfiles++-- | The result of a static analysis, in the two shapes @analysis.json@+-- holds: a set of names, or a set of paths.+data AnalysisResult+  = Names (Set Text)+  | Paths (Set [Text])+  deriving (Eq, Show)++-- | The static analyses (reference.md \S9) this port provides to an+-- @"expect": "analysis"@ case, by the name @analysis.json@ gives them. A case+-- naming any other one is skipped.+providedAnalyses :: Map.Map Text (LibraryTable -> Program -> AnalysisResult)+providedAnalyses =+  Map.fromList+    [ ("staticImportNames", \_ p -> Names (staticImportNames p))+    , ("transitiveImportNames", \libs p -> Names (transitiveImportNames libs p))+    , ("staticActionKeys", \_ p -> Names (staticActionKeys p))+    , ("deepActionKeys", \libs p -> Names (deepActionKeys libs p))+    , ("contextHoles", \_ p -> Paths (contextHoles p))+    , ("deepContextHoles", \libs p -> Paths (deepContextHoles libs p))+    , ("contextReads", \_ p -> Paths (contextReads p))+    , ("arithmeticOps", \_ p -> Names (arithmeticOps p))+    , ("deepArithmeticOps", \libs p -> Names (deepArithmeticOps libs p))+    ]++-- | What 'checkCase' did with a case. A failing case throws instead.+data Outcome+  = Passed+  | -- | Not run: the case names these profiles (or, written+    -- @analysis \<name\>@, these analyses), which this port does not provide.+    Skipped [Text]+  deriving (Eq, Show)+ spec :: Spec spec = do   root <- runIO findCorpusRoot   cases <- runIO (loadCaseDirs root)   describe "shared corpus" $     mapM_ (\dir -> it (takeFileName dir) (runCase dir)) cases+  describe "a case naming a profile this port does not provide" $+    -- corpus/runner-checks/unsupported-profile would fail if it ran: its+    -- expected.json does not match what the template evaluates to.+    it "is skipped" $+      checkCase (root </> ".." </> "runner-checks" </> "unsupported-profile")+        `shouldReturn` Skipped ["never-declared"]  -- | The corpus lives at @corpus/cases@ relative to the repo root, but -- @cabal test@'s working directory depends on how it is invoked -- walk@@ -82,6 +159,16 @@   bytes <- BS.readFile path   either (\e -> error (path <> ": " <> e)) pure (eitherDecodeStrict bytes) +-- | Reads @ctx.json@ or @expected.json@ with the reader that types a number+-- by its text (@corpus/README.md@): @3@ is an integer and @3.0@ a float, and+-- an integer keeps its digits whatever its size. aeson's own decoder would+-- make the two one number, and no fixture could then catch a result of the+-- wrong type.+readTypedJsonFile :: FilePath -> IO Json+readTypedJsonFile path = do+  bytes <- BS.readFile path+  either (\e -> error (path <> ": " <> e)) pure (jsonParser (TE.decodeUtf8 bytes))+ readLibs :: FilePath -> IO LibraryTable readLibs dir = do   let libsDir = dir </> "libs"@@ -98,19 +185,86 @@           Right prog -> pure (name, prog)       pure (Map.fromList entries) -modeFromMeta :: FilePath -> Text -> IO Mode+modeFromMeta :: FilePath -> Maybe Text -> IO Mode modeFromMeta dir m = case m of-  "concrete" -> pure Concrete-  "symbolic" -> pure Symbolic-  other -> error (dir <> ": unknown mode " <> T.unpack other)+  Just "concrete" -> pure Concrete+  Just "symbolic" -> pure Symbolic+  Just other -> error (dir <> ": unknown mode " <> T.unpack other)+  Nothing -> error (dir <> ": meta.json has no mode") +-- | The options a case runs with: its mode, and the arithmetic profile only+-- if it lists @arithmetic@ in @profiles@. Every other case runs with the+-- profile off, as a host that never asked for it does, so the ten+-- arithmetic names are unbound there.+optionsFromMeta :: FilePath -> CaseMeta -> IO Options+optionsFromMeta dir meta = do+  mode <- modeFromMeta dir (metaMode meta)+  pure defaultOptions {optMode = mode, optArithmetic = "arithmetic" `elem` metaProfiles meta}++-- | A skipped case is reported as pending, which hspec counts and prints+-- apart from the passed ones. runCase :: FilePath -> Expectation runCase dir = do+  outcome <- checkCase dir+  case outcome of+    Passed -> pure ()+    Skipped missing -> pendingWith ("not provided: " <> T.unpack (T.intercalate ", " missing))++checkCase :: FilePath -> IO Outcome+checkCase dir = do   meta <- (readJsonFile (dir </> "meta.json") :: IO CaseMeta)-  mode <- modeFromMeta dir (metaMode meta)+  when (metaHasRequires meta) $+    error (dir <> ": \"requires\" was replaced by \"profiles\" (corpus/README.md)")+  if metaExpect meta == "analysis"+    then do+      -- The names are the keys of @analysis.json@, which holds no number, so+      -- reading it before deciding to skip is safe on every port.+      expected <- (readJsonFile (dir </> "analysis.json") :: IO (Map.Map Text Aeson.Value))+      let missingAnalyses = filter (`Map.notMember` providedAnalyses) (Map.keys expected)+      case missingProfiles meta <> map ("analysis " <>) missingAnalyses of+        [] -> Passed <$ checkAnalysisCase dir meta expected+        missing -> pure (Skipped missing)+    else case missingProfiles meta of+      [] -> Passed <$ checkSupportedCase dir meta+      missing -> pure (Skipped missing)++-- | An @"expect": "analysis"@ case: no context and no evaluation. Each named+-- analysis runs over the parsed template (and @libs/@, for a deep variant)+-- and its result is compared, as a set, with the array @analysis.json@ gives.+checkAnalysisCase :: FilePath -> CaseMeta -> Map.Map Text Aeson.Value -> Expectation+checkAnalysisCase dir meta expected = do   src <- TE.decodeUtf8 <$> BS.readFile (dir </> "template.tramaj")   libs <- readLibs dir   let label = T.unpack (metaName meta)+  case parseProgram src of+    Left e -> expectationFailure (label <> ": parse error: " <> show e)+    Right prog -> forM_ (Map.toList expected) $ \(key, value) ->+      case Map.lookup key providedAnalyses of+        Nothing -> expectationFailure (label <> ": unknown analysis " <> T.unpack key)+        Just analysis ->+          let actual = analysis libs prog+           in case decodeExpected actual value of+                Left e -> expectationFailure (label <> ": analysis.json: " <> T.unpack key <> ": " <> e)+                Right want -> (key, actual) `shouldBe` (key, want)+  where+    -- Decoded in the shape of the actual result, since @[]@ alone does not+    -- say which of the two it is. A repeated element is refused: the file is+    -- a set.+    decodeExpected :: AnalysisResult -> Aeson.Value -> Either String AnalysisResult+    decodeExpected (Names _) v = Names <$> (distinct =<< parseEither parseJSON v)+    decodeExpected (Paths _) v = Paths <$> (distinct =<< parseEither parseJSON v)++    distinct :: (Ord a) => [a] -> Either String (Set a)+    distinct xs =+      let set = Set.fromList xs+       in if Set.size set == length xs then Right set else Left "an element is repeated"++checkSupportedCase :: FilePath -> CaseMeta -> Expectation+checkSupportedCase dir meta = do+  options <- optionsFromMeta dir 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 ()@@ -118,10 +272,15 @@     "eval-error" -> case metaErrorKind meta of       Nothing -> expectationFailure (label <> ": eval-error case needs errorKind")       Just errorKind -> do-        ctx <- (readJsonFile (dir </> "ctx.json") :: IO Value)+        ctx <- readTypedJsonFile (dir </> "ctx.json")         case parseProgram src of           Left e -> expectationFailure (label <> ": parse error: " <> show e)-          Right prog -> case evalProgram mode libs ctx prog of+          -- 'runProgramWith', as for a success case and as corpus/README.md+          -- says of @mode@: in symbolic mode it also builds the envelope's+          -- @"types"@ table, which is where an annotation naming an+          -- undeclared type is refused. Every error 'evalProgramWith' raises+          -- is raised first by 'runProgramWith'.+          Right prog -> case runProgramWith options libs ctx prog of             Right _ -> expectationFailure (label <> ": expected eval error " <> T.unpack errorKind <> ", but evaluation succeeded")             Left e ->               let actualKind = errorConstructor e@@ -129,13 +288,21 @@                     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)+      ctx <- readTypedJsonFile (dir </> "ctx.json")+      expected <- readTypedJsonFile (dir </> "expected.json")       case parseProgram src of         Left e -> expectationFailure (label <> ": parse error: " <> show e)-        Right prog -> case runProgram mode libs ctx prog of+        Right prog -> case runProgramWith options libs ctx prog of           Left e -> expectationFailure (label <> ": eval error: " <> show e)-          Right actual -> encode actual `shouldBe` (encode expected :: BL.ByteString)+          -- Typed values, so an integer @1@ against an expected float @1.0@+          -- is a failure: the text of every number is compared, up to the+          -- spelling of one value of one type (@1.0@ and @1e0@ are the same+          -- float). Object key order is not compared.+          --+          -- The result goes through the writer and the reader first, since+          -- the text is what a host receives: a float written without its+          -- fraction would read back as an integer and fail here.+          Right actual -> jsonParser (stringify actual) `shouldBe` Right expected     other -> expectationFailure (label <> ": unknown expect " <> T.unpack other)  -- | The constructor name an 'EvalError''s 'Show' instance leads with -- every

@@ -6,17 +6,16 @@ -- 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.Ast (Expr (..), Program (..)) import Tramaj.Eval+import Tramaj.Json (Json (..)) import Tramaj.Node import Tramaj.Parser+import Tramaj.TestJson (ToJ (..), object, (.=)) import Tramaj.Types (TypeError (..))  spec :: Spec@@ -34,6 +33,8 @@   adaptSpec   errorSpec   typeSpec+  arithmeticSpec+  sortSpec  -- Helpers ------------------------------------------------------------------- @@ -53,32 +54,32 @@  -- | 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 :: Text -> Json -> 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 :: Text -> Json -> Either String Json 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 :: Text -> Json -> Either String Json 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 :: (EvalError -> Bool) -> Text -> Json -> 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 :: Text -> [Json] -> [Json] -> Json -> Json elemJ tag attrs children value =   object     [ "type" .= ("element" :: Text)@@ -89,27 +90,27 @@     , "annotations" .= object []     ] -el :: Text -> [Value] -> Value-el tag children = elemJ tag [] children Null+el :: Text -> [Json] -> Json+el tag children = elemJ tag [] children JNull  -- | A JSON array, spelled as a list at the call site.-arr :: [Value] -> Value-arr = Array . V.fromList+arr :: [Json] -> Json+arr = JArray -textJ :: Value -> Value+textJ :: Json -> Json textJ v = object ["type" .= ("text" :: Text), "value" .= v, "annotations" .= object []] -fragJ :: [Value] -> Value+fragJ :: [Json] -> Json fragJ children = object ["type" .= ("fragment" :: Text), "children" .= children, "annotations" .= object []] -attrJ :: Text -> Value -> Value+attrJ :: Text -> Json -> Json attrJ name v = object ["kind" .= ("attribute" :: Text), "name" .= name, "value" .= v] -actionJ :: Text -> Text -> Value -> Value+actionJ :: Text -> Text -> Json -> Json actionJ event key payload =   object ["kind" .= ("action" :: Text), "event" .= event, "key" .= key, "payload" .= payload] -items :: [Text] -> Value+items :: [Text] -> Json items names = object ["items" .= [object ["name" .= n] | n <- names]]  -- Documents -------------------------------------------------------------------@@ -117,16 +118,16 @@ 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")]])+    doc ".div(.p(\"Hello\"))" JNull `shouldBe` Right (el "div" [el "p" [textJ (JString "Hello")]])    it "puts attributes and children in source order" $-    doc ".div(class: \"panel\", \"data-id\": 7, .h1(\"T\"), .p(\"B\"))" Null+    doc ".div(class: \"panel\", \"data-id\": 7, .h1(\"T\"), .p(\"B\"))" JNull       `shouldBe` Right         ( elemJ             "div"-            [attrJ "class" (String "panel"), attrJ "data-id" (Number 7)]-            [el "h1" [textJ (String "T")], el "p" [textJ (String "B")]]-            Null+            [attrJ "class" (JString "panel"), attrJ "data-id" (JInt 7)]+            [el "h1" [textJ (JString "T")], el "p" [textJ (JString "B")]]+            JNull         )    it "keeps an attribute value as a value rather than a display string" $@@ -134,30 +135,30 @@       `shouldBe` Right         ( elemJ             "div"-            [attrJ "count" (Number 3), attrJ "tags" (arr [Number 1, Number 2]), attrJ "on" (Bool True)]+            [attrJ "count" (JInt 3), attrJ "tags" (arr [JInt 1, JInt 2]), attrJ "on" (JBool True)]             []-            Null+            JNull         )    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)+    doc ".Replicas(value($ctx.n))" (object ["n" .= (3 :: Int)]) `shouldBe` Right (elemJ "Replicas" [] [] (JInt 3))+    doc ".Replicas()" JNull `shouldBe` Right (elemJ "Replicas" [] [] JNull)    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")]]])+    doc "@header=.header(.h1(\"T\"))\n.main($header)" JNull+      `shouldBe` Right (el "main" [el "header" [el "h1" [textJ (JString "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")]])+    doc "@row=(x) => .li($x)\n.ul($row(\"a\"), $row(\"b\"))" JNull+      `shouldBe` Right (el "ul" [el "li" [textJ (JString "a")], el "li" [textJ (JString "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")])+      (object ["items" .= arr [JString "a", JString "b"]])+      `shouldBe` Right (el "p" [textJ (JString "2 -- so far")])  -- Scalars ------------------------------------------------------------------------ @@ -165,64 +166,77 @@ 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)])+    doc ".td($ctx.count)" (object ["count" .= (3 :: Int)]) `shouldBe` Right (el "td" [textJ (JInt 3)])    it "keeps booleans, null and objects unconverted" $-    doc ".div(true, null, {\"a\": 1})" Null+    doc ".div(true, null, {\"a\": 1})" JNull       `shouldBe` Right-        (el "div" [textJ (Bool True), textJ Null, textJ (object ["a" .= (1 :: Int)])])+        (el "div" [textJ (JBool True), textJ JNull, 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")])+    doc ".div([1, \"a\"])" JNull `shouldBe` Right (el "div" [textJ (JInt 1), textJ (JString "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")])+      `shouldBe` Right (el "p" [textJ (JString "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")+    val "\"`$ctx.n`\"" (object ["n" .= (3 :: Int)]) `shouldBe` Right (JString "3")    it "resolves escape sequences" $-    val "\"a\\tb\\nc\\u{1F600}\"" Null `shouldBe` Right (String "a\tb\nc\128512")+    val "\"a\\tb\\nc\\u{1F600}\"" JNull `shouldBe` Right (JString "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+-- rather than described loosely; a float follows ECMAScript's -- @Number::toString@, which is simply what a number's text is on the--- PureScript implementation's host.+-- PureScript implementation's host, with @.0@ appended when that text has+-- neither a fraction nor an exponent. 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)+          val ("str(" <> src <> ")") JNull `shouldBe` Right (JString expected)    renders "\"hi\"" "hi"   renders "null" ""   renders "true" "true"   renders "false" "false" +  -- An integer is its digits; a float always carries a fraction or an+  -- exponent, so @str@ keeps the two apart (reference.md \S6).   renders "3" "3"+  renders "-7" "-7"+  renders "123456789" "123456789"+  renders "9223372036854775807" "9223372036854775807"+  renders "3.0" "3.0"+  renders "0.0" "0.0"+  renders "-0.0" "0.0"   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.+  -- integrality test went through a 32-bit Int. It is now what the float+  -- of that value renders as, and the integer renders without it.   renders "100000000000" "100000000000"+  renders "100000000000.0" "100000000000.0"    -- The thresholds where ECMAScript switches to scientific notation.-  renders "1000000000000000000000" "1e+21"+  renders "1000000000000000000000.0" "1e+21"+  renders "100000000000000000000.0" "100000000000000000000.0"   renders "0.0000001" "1e-7"+  renders "0.000001" "0.000001"    -- v1 rendered these through Haskell's own Show, leaking-  -- "Array [Number 1.0,Number 2.0]" into template output.+  -- "Array [JInt 1.0,JInt 2.0]" into template output.   renders "[1, 2]" "[1,2]"+  renders "[1, 1.0]" "[1,1.0]"   renders "{\"a\": 1}" "{\"a\":1}"    -- Keys are sorted: object key order is not semantically significant, so@@ -230,37 +244,37 @@   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")+    val "str([\"a\\\"b\"])" JNull `shouldBe` Right (JString "[\"a\\\"b\"]")+    val "str(\"a\\\"b\")" JNull `shouldBe` Right (JString "a\"b")    it "is what string interpolation uses" $-    val "\"n=`$ctx.xs`\"" (object ["xs" .= ([1, 2] :: [Int])]) `shouldBe` Right (String "n=[1,2]")+    val "\"n=`$ctx.xs`\"" (object ["xs" .= ([1, 2] :: [Int])]) `shouldBe` Right (JString "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")]])+    doc ".(.p(\"one\"), .p(\"two\"))" JNull+      `shouldBe` Right (fragJ [el "p" [textJ (JString "one")], el "p" [textJ (JString "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")]]])+    doc ".div(.(.p(\"a\")))" JNull `shouldBe` Right (el "div" [fragJ [el "p" [textJ (JString "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+    doc "@kids=.(.p(\"a\"), .p(\"b\"))\n@panel=(t, c) => .section(.h2($t), $c)\n$panel(\"T\", $kids)" JNull       `shouldBe` Right         ( el             "section"-            [ el "h2" [textJ (String "T")]-            , fragJ [el "p" [textJ (String "a")], el "p" [textJ (String "b")]]+            [ el "h2" [textJ (JString "T")]+            , fragJ [el "p" [textJ (JString "a")], el "p" [textJ (JString "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")]])+      `shouldBe` Right (fragJ [el "button" [textJ (JString "a")], el "button" [textJ (JString "b")]])  -- Actions ------------------------------------------------------------------------- @@ -272,19 +286,19 @@         ( elemJ             "b"             [actionJ "on-click" "deploy" (object ["id" .= (1 :: Int)])]-            [textJ (String "Go")]-            Null+            [textJ (JString "Go")]+            JNull         )    -- 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+    doc ".b(class: \"c\", action(\"on-click\", \"a\", {}), action(\"on-key\", \"b\", {}))" JNull       `shouldBe` Right         ( elemJ             "b"-            [attrJ "class" (String "c"), actionJ "on-click" "a" (object []), actionJ "on-key" "b" (object [])]+            [attrJ "class" (JString "c"), actionJ "on-click" "a" (object []), actionJ "on-key" "b" (object [])]             []-            Null+            JNull         )  -- Bindings ----------------------------------------------------------------------------@@ -292,24 +306,24 @@ 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)])+    val "@a=1\n@b=$a\n{\"b\": $b}" JNull `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"+    val "@a=$b\n@b=1\n$a" JNull `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)+    val "@t=10\n@big=(x) => gt($x, $t)\n@t2=$big(42)\n$t2" JNull `shouldBe` Right (JBool 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"+    val "@f=(x) => $f($x)\n$f(1)" JNull `shouldSatisfy` isLeftWith "UnboundName"    it "allows kebab-case names" $-    val "@my-var=1\n$my-var" Null `shouldBe` Right (Number 1)+    val "@my-var=1\n$my-var" JNull `shouldBe` Right (JInt 1)    it "passes a builtin by reference" $-    val "map($ctx.xs, $not)" (object ["xs" .= [True, False]]) `shouldBe` Right (arr [Bool False, Bool True])+    val "map($ctx.xs, $not)" (object ["xs" .= [True, False]]) `shouldBe` Right (arr [JBool False, JBool True])   where     isLeftWith needle = either (\e -> needle `elem` words (map (\c -> if c == '"' then ' ' else c) e)) (const False) @@ -317,25 +331,25 @@  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 "joins strings" $ val "\"a\" <> \"b\"" JNull `shouldBe` Right (JString "ab")+  it "appends arrays" $ val "[1, 2] <> [3]" JNull `shouldBe` Right (arr [JInt 1, JInt 2, JInt 3])    it "merges objects right-biased" $-    val "{\"a\": 1, \"b\": 2} <> {\"b\": 3, \"c\": 4}" Null+    val "{\"a\": 1, \"b\": 2} <> {\"b\": 3, \"c\": 4}" JNull       `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")+    val "\"a\" <> \"b\" <> \"c\"" JNull `shouldBe` Right (JString "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)])+    val "\"a\" <> \"\"" JNull `shouldBe` Right (JString "a")+    val "[1] <> []" JNull `shouldBe` Right (arr [JInt 1])+    val "{\"a\": 1} <> {}" JNull `shouldBe` Right (object ["a" .= (1 :: Int)])   where-    failsWith' src p = failsWith p src Null+    failsWith' src p = failsWith p src JNull  -- Branch ---------------------------------------------------------------------------------- @@ -344,25 +358,25 @@ 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")+      `shouldBe` Right (JString "error")    it "falls back when no predicate holds" $-    val "branch(\"unknown\", false, \"a\")" Null `shouldBe` Right (String "unknown")+    val "branch(\"unknown\", false, \"a\")" JNull `shouldBe` Right (JString "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")]])+      `shouldBe` Right (el "div" [el "p" [textJ (JString "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")+    val "branch(\"fallback\", false, $nope.deeply.broken)" JNull `shouldBe` Right (JString "fallback")    it "does not evaluate a later predicate once one has matched" $-    val "branch(\"fallback\", true, \"first\", $nope, \"second\")" Null `shouldBe` Right (String "first")+    val "branch(\"fallback\", true, \"first\", $nope, \"second\")" JNull `shouldBe` Right (JString "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+    failsWithT src p = failsWith p src JNull  -- Collections ------------------------------------------------------------------------------- @@ -370,27 +384,27 @@ 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")]])+      `shouldBe` Right (el "ul" [el "li" [textJ (JString "a")], el "li" [textJ (JString "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"])+    val "map($ctx.items, (i) => $i.name)" (items ["a", "b"]) `shouldBe` Right (arr [JString "a", JString "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")]])+        (el "ul" [el "li" [textJ (JString "first")], el "li" [textJ (JString "a")], el "li" [textJ (JString "last")]])    it "filters" $     val "filter($ctx.xs, (x) => gt($x, 1))" (object ["xs" .= ([1, 2, 3] :: [Int])])-      `shouldBe` Right (arr [Number 2, Number 3])+      `shouldBe` Right (arr [JInt 2, JInt 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])+      `shouldBe` Right (arr [JInt 0, JInt 1, JInt 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)+    val "fold($ctx.xs, 0, (a, x) => $x)" (object ["xs" .= ([1, 2] :: [Int])]) `shouldBe` Right (JInt 2)    it "scopes the lambda parameter to its own body" $     val "@r=map($ctx.xs, (x) => $x)\n$x" (object ["xs" .= ([1] :: [Int])])@@ -401,15 +415,15 @@ 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)]])+    doc "import(\"panel\", {\"name\": \"web\", \"replicas\": 3}).rendered" JNull+      `shouldBe` Right (el "section" [el "h2" [textJ (JString "web")], el "p" [textJ (JInt 3)]])    it "exposes an expression-rooted library's result" $-    val "import(\"data\", {\"b\": 2}).rendered" Null+    val "import(\"data\", {\"b\": 2}).rendered" JNull       `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)+    val "import(\"data\", {\"b\": 2}).vals.a" JNull `shouldBe` Right (JInt 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.@@ -417,29 +431,29 @@     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)]])+      `shouldBe` Right (el "section" [el "h2" [textJ (JString "web")], el "p" [textJ (JInt 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)]])+    doc "@p=import(\"panel\", {\"name\": \"web\"})\n$p({\"replicas\": 3}).rendered" JNull+      `shouldBe` Right (el "section" [el "h2" [textJ (JString "web")], el "p" [textJ (JInt 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)]])+    doc "@p=import(\"panel\", {})\n@half=$p({\"name\": \"web\"})\n$half({\"replicas\": 2}).rendered" JNull+      `shouldBe` Right (el "section" [el "h2" [textJ (JString "web")], el "p" [textJ (JInt 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)]])+      `shouldBe` Right (el "section" [el "h2" [textJ (JString "web")], el "p" [textJ (JInt 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]))+    val "@p=import(\"data\", {})\nmap([1, 2], (b) => $p({\"b\": $b}).rendered.b)" JNull+      `shouldBe` Right (JArray [JInt 1, JInt 2])    it "reports a parameter nobody supplied as the library's own missing path" $-    run "import(\"panel\", {\"name\": \"web\"}).rendered" Null+    run "import(\"panel\", {\"name\": \"web\"}).rendered" JNull       `shouldBe` Left (show (InLibrary "panel" (PathNotFound ["ctx", "replicas"])))    it "reports a ctx(path) the importing context lacks, at the import" $@@ -461,122 +475,122 @@     ("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)+    val "import(\"data\", {\"b\": 2}).vals.a" JNull `shouldBe` Right (JInt 1)   where-    failsWithN src p = failsWith p src Null+    failsWithN src p = failsWith p src JNull  -- 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+    doc "adapt-actions(import(\"two-actions\", {}).rendered, prefix(\"user:\"))" JNull       `shouldBe` Right         ( el             "div"-            [ elemJ "b" [actionJ "on-click" "user:save" (object [])] [] Null-            , elemJ "b" [actionJ "on-click" "user:delete" (object [])] [] Null+            [ elemJ "b" [actionJ "on-click" "user:save" (object [])] [] JNull+            , elemJ "b" [actionJ "on-click" "user:delete" (object [])] [] JNull             ]         )    it "composes, outermost prefix last" $-    val "cardinality({})" Null `shouldBe` Right (Number 0)+    val "cardinality({})" JNull `shouldBe` Right (JInt 0)    it "composes two adaptations as b:a:key" $-    doc "adapt-actions(adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, prefix(\"a:\")), prefix(\"b:\"))" Null+    doc "adapt-actions(adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, prefix(\"a:\")), prefix(\"b:\"))" JNull       `shouldBe` Right         ( elemJ             "button"             [actionJ "on-click" "b:a:deploy" (object ["n" .= ("w" :: Text)])]-            [textJ (String "go: w")]-            Null+            [textJ (JString "go: w")]+            JNull         )    it "leaves keys alone under the identity adaptation" $-    doc "adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, identity)" Null+    doc "adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, identity)" JNull       `shouldBe` Right         ( elemJ             "button"             [actionJ "on-click" "deploy" (object ["n" .= ("w" :: Text)])]-            [textJ (String "go: w")]-            Null+            [textJ (JString "go: w")]+            JNull         )    -- 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+    doc "adapt-actions(import(\"button\", {\"name\": \"w\"}).rendered, prefix(\"x:\"), (a) => {\"eventType\": \"on-tap\", \"key\": \"ignored\", \"payload\": {\"orig\": $a.key}})" JNull       `shouldBe` Right         ( elemJ             "button"             [actionJ "on-tap" "x:deploy" (object ["orig" .= ("x:deploy" :: Text)])]-            [textJ (String "go: w")]-            Null+            [textJ (JString "go: w")]+            JNull         )    it "reaches actions inside a nested import" $-    doc "adapt-actions(import(\"wrapper\", {}).rendered, prefix(\"w:\"))" Null+    doc "adapt-actions(import(\"wrapper\", {}).rendered, prefix(\"w:\"))" JNull       `shouldBe` Right         ( el             "div"             [ elemJ                 "button"                 [actionJ "on-click" "w:deploy" (object ["n" .= ("inner" :: Text)])]-                [textJ (String "go: inner")]-                Null+                [textJ (JString "go: inner")]+                JNull             ]         )    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+    doc "@p=import(\"button\", {})\n@a=adapt-actions($p, prefix(\"q:\"))\n$a({\"name\": \"w\"}).rendered" JNull       `shouldBe` Right         ( elemJ             "button"             [actionJ "on-click" "q:deploy" (object ["n" .= ("w" :: Text)])]-            [textJ (String "go: w")]-            Null+            [textJ (JString "go: w")]+            JNull         )    it "leaves ordinary attributes and the value slot untouched" $-    doc "adapt-actions(.b(class: \"c\", value(1), action(\"on-click\", \"k\", {})), prefix(\"p:\"))" Null+    doc "adapt-actions(.b(class: \"c\", value(1), action(\"on-click\", \"k\", {})), prefix(\"p:\"))" JNull       `shouldBe` Right-        (elemJ "b" [attrJ "class" (String "c"), actionJ "on-click" "p:k" (object [])] [] (Number 1))+        (elemJ "b" [attrJ "class" (JString "c"), actionJ "on-click" "p:k" (object [])] [] (JInt 1))    it "passes through a value that has no actions at all" $-    val "adapt-actions(\"plain\", prefix(\"p:\"))" Null `shouldBe` Right (String "plain")+    val "adapt-actions(\"plain\", prefix(\"p:\"))" JNull `shouldBe` Right (JString "plain")  -- Errors ----------------------------------------------------------------------------------------------  errorSpec :: Spec errorSpec = describe "errors" $ do   it "reports an unbound name" $-    (failsWith (\case UnboundName _ -> True; _ -> False) "$nope" Null) `shouldBe` True+    (failsWith (\case UnboundName _ -> True; _ -> False) "$nope" JNull) `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+    (failsWith (\case TypeMismatch _ -> True; _ -> False) "@f=(x) => $x\n[$f, 1]" JNull) `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])+    val "@f=(x) => $x\n[$f(1), 2]" JNull `shouldBe` Right (arr [JInt 1, JInt 2])    it "refuses a document used where a plain value is expected" $-    (failsWith (\case TypeMismatch _ -> True; _ -> False) ".div(class: .p(\"x\"))" Null) `shouldBe` True+    (failsWith (\case TypeMismatch _ -> True; _ -> False) ".div(class: .p(\"x\"))" JNull) `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+    (failsWith (\case TypeMismatch _ -> True; _ -> False) "@f=(x, y) => $x\n$f(1)" JNull) `shouldBe` True    it "reports a non-array given to map" $-    (failsWith (\case TypeMismatch _ -> True; _ -> False) "map(1, (x) => $x)" Null) `shouldBe` True+    (failsWith (\case TypeMismatch _ -> True; _ -> False) "map(1, (x) => $x)" JNull) `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 -> Text -> Json -> Either String Json 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)@@ -584,66 +598,205 @@ 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+    runMode Concrete "@d : string = \"x\"\n$d" JNull+      `shouldBe` runMode Concrete "@d = \"x\"\n$d" JNull    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+    case runMode Symbolic "type Deployment = { replicas : int }\n@d : Deployment = {\"replicas\": 3}\n$d" JNull of+      Right (JObject o) ->+        Map.lookup "constraints" o           `shouldBe` Just-            ( Array-                ( V.fromList-                    [ object-                        [ "name" .= ("has-type" :: Text)-                        , "arguments"-                            .= [ object ["replicas" .= (3 :: Int)]-                               , object ["$type" .= ("root:Deployment" :: Text)]-                               ]-                        ]+            ( JArray+                [ 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+    case runMode Symbolic "type Deployment = { replicas : int }\n@d : Deployment = {\"replicas\": 3}\n$d" JNull of+      Right (JObject o) ->+        Map.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)]]]-                              ]-                        ]+            ( JArray+                [ object+                    [ "id" .= ("root:Deployment" :: Text)+                    , "definition"+                        .= object+                          [ "kind" .= ("record" :: Text)+                          , "fields" .= [object ["name" .= ("replicas" :: Text), "type" .= object ["kind" .= ("prim" :: Text), "name" .= ("int" :: 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)+    case runMode Symbolic "type Json = string\n!type-constraint(\"has-default\", %Json)\ntrue" JNull of+      Right (JObject o) -> do+        Map.lookup "type-constraints" o+          `shouldBe` Just (JArray [object ["name" .= ("has-default" :: Text), "arguments" .= [object ["$type" .= ("root:Json" :: Text)]]]])+        Map.lookup "constraints" o `shouldBe` Just (JArray [])       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)+    case runMode Symbolic "1" JNull of+      Right (JObject o) -> do+        Map.lookup "types" o `shouldBe` Just (JArray [])+        Map.lookup "type-constraints" o `shouldBe` Just (JArray [])       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+     in case runProgram Concrete libsHere JNull p of           Left (TypeErr (PartialType _ _)) -> pure ()           other -> expectationFailure ("expected a PartialType error, got " <> show other)++-- | The arithmetic profile as an option of one evaluation (reference.md+-- \S11, v3-symbols \S5.5). What the builtins compute is the shared+-- corpus's business; here is what it has no shape for: the option, its+-- default, and the ends of the 64-bit range in integer division.+arithmeticSpec :: Spec+arithmeticSpec = describe "the arithmetic profile" $ do+  let on mode = defaultOptions {optMode = mode, optArithmetic = True}+      parsed src = either (\e -> error ("fixture does not parse: " <> show e)) id (parseProgram src)+      withOptions options libsHere src ctx = runProgramWith options libsHere ctx (parsed src)+      arith src = withOptions (on Concrete) Map.empty src JNull+      isUnbound name = \case+        Left (UnboundName n) -> n == name+        _ -> False+      isTypeMismatch = \case+        Left (TypeMismatch _) -> True+        _ -> False+      isNotRepresentable = \case+        Left (NotRepresentable _) -> True+        _ -> False+      symS = object ["$sym" .= ("#ctx.s" :: Text), "path" .= ([] :: [Text])]+      termS = object ["$term" .= ("sum" :: Text), "arguments" .= [symS, toJ (1 :: Int)]]+      adds = Map.fromList [("adds", parsed "@total=sum($ctx.a, 1)\n$total")]++  it "is off by default: concrete mode, no arithmetic" $+    defaultOptions `shouldBe` Options {optMode = Concrete, optArithmetic = False}++  it "leaves the names unbound through evalProgram and runProgram" $ do+    evalProgram Concrete Map.empty JNull (parsed "sum(1, 2)") `shouldSatisfy` isUnbound "sum"+    runProgram Concrete Map.empty JNull (parsed "sum(1, 2)") `shouldSatisfy` isUnbound "sum"+    runProgram Symbolic Map.empty JNull (parsed "map([1.5], $floor)") `shouldSatisfy` isUnbound "floor"++  it "leaves them unbound with the option off, and binds them with it on" $ do+    withOptions defaultOptions Map.empty "sum(1, 2)" JNull `shouldSatisfy` isUnbound "sum"+    withOptions (on Concrete) Map.empty "sum(1, 2)" JNull `shouldBe` Right (JInt 3)+    evalProgramWith (on Concrete) Map.empty JNull (parsed "sum(1, 2)") `shouldBe` Right (OValue (JInt 3))++  it "keeps a program that binds one of the names working with the option off" $+    runProgram Concrete Map.empty JNull (parsed "@sum=(a, b) => $a\n$sum(1, 2)") `shouldBe` Right (JInt 1)++  it "runs a library with the profile of the evaluation that reached it" $ do+    withOptions (on Concrete) adds "import(\"adds\", {a: 2}).vals.total" JNull `shouldBe` Right (JInt 3)+    withOptions defaultOptions adds "import(\"adds\", {a: 2}).vals.total" JNull+      `shouldBe` Left (InLibrary "adds" (UnboundName "sum"))++  it "accepts a seeded term in symbolic mode with the profile on, and hands it back" $+    case withOptions (on Symbolic) Map.empty "$ctx.t" (object ["t" .= termS]) of+      Right (JObject o) -> Map.lookup "root" o `shouldBe` Just termS+      other -> expectationFailure ("expected a symbolic envelope object, got " <> show other)++  it "refuses every seeded term with the profile off, read or not" $ do+    runProgram Symbolic Map.empty (object ["t" .= termS]) (parsed "$ctx.t") `shouldSatisfy` isTypeMismatch+    runProgram Symbolic Map.empty (object ["t" .= termS]) (parsed "1") `shouldSatisfy` isTypeMismatch++  it "refuses the reserved \"$term\" key in concrete mode whatever the profile" $ do+    withOptions (on Concrete) Map.empty "1" (object ["t" .= termS]) `shouldSatisfy` isTypeMismatch+    withOptions defaultOptions Map.empty "1" (object ["$term" .= (1 :: Int)]) `shouldSatisfy` isTypeMismatch++  it "keeps the two number types with the profile off" $+    runProgram Concrete Map.empty JNull (parsed "[eq(1, 1.0), 1, 1.0]")+      `shouldBe` Right (JArray [JBool False, JInt 1, JFloat 1.0])++  it "builds a term over a seeded symbol only with the profile on" $ do+    case withOptions (on Symbolic) Map.empty "sum($ctx.s, 1)" (object ["s" .= symS]) of+      Right (JObject o) -> Map.lookup "root" o `shouldBe` Just termS+      other -> expectationFailure ("expected a symbolic envelope object, got " <> show other)+    runProgram Symbolic Map.empty (object ["s" .= symS]) (parsed "sum($ctx.s, 1)") `shouldSatisfy` isUnbound "sum"++  it "divides exactly at the ends of the 64-bit range" $ do+    arith "floor-quotient(9223372036854775807, 2)" `shouldBe` Right (JInt 4611686018427387903)+    arith "floor-quotient(-9223372036854775808, 2)" `shouldBe` Right (JInt (-4611686018427387904))+    arith "floor-quotient(-9223372036854775808, 1)" `shouldBe` Right (JInt (-9223372036854775808))+    arith "floor-quotient(9223372036854775807, -1)" `shouldBe` Right (JInt (-9223372036854775807))+    arith "floor-quotient(-9223372036854775807, 9223372036854775807)" `shouldBe` Right (JInt (-1))+    arith "floor-quotient(9223372036854775807, -9223372036854775808)" `shouldBe` Right (JInt (-1))+    arith "modulo(9223372036854775807, -9223372036854775808)" `shouldBe` Right (JInt (-1))+    arith "modulo(-9223372036854775808, 9223372036854775807)" `shouldBe` Right (JInt 9223372036854775806)+    arith "modulo(-9223372036854775807, 2)" `shouldBe` Right (JInt 1)++  it "never wraps: a product or a sum that leaves the 64-bit range is an error at that step" $ do+    arith "product(-9223372036854775808, -1)" `shouldSatisfy` isNotRepresentable+    arith "product(4294967296, 4294967296, 0)" `shouldSatisfy` isNotRepresentable+    arith "product(3037000500, 3037000500)" `shouldSatisfy` isNotRepresentable+    arith "sum(-9223372036854775808, -9223372036854775808, 9223372036854775807)" `shouldSatisfy` isNotRepresentable+    arith "sum(-9223372036854775808, 9223372036854775807, 1)" `shouldBe` Right (JInt 0)++  it "folds floats left to right, one rounding at a time" $ do+    arith "sum(0.1, 0.2, 0.3)" `shouldBe` Right (JFloat 0.6000000000000001)+    arith "sum(1e16, 1.0, 1.0)" `shouldBe` Right (JFloat 1.0e16)+    arith "sum(1.0, 1.0, 1e16)" `shouldBe` Right (JFloat 1.0000000000000002e16)+    arith "product(49.0, inverse(49.0))" `shouldBe` Right (JFloat 0.9999999999999999)++-- | Sorting (reference.md \S11). What a sort gives is the shared corpus's+-- business; here is what no program can observe and the corpus therefore+-- cannot state: how many times the key function is applied. The key+-- function below emits one constraint each time it runs. A lambda written+-- in a template cannot do that, so the program is built as an AST, and+-- 'emittedConstraintCount' counts the emissions before equal ones are made+-- one.+sortSpec :: Spec+sortSpec = describe "the key function of a sort" $ do+  let row :: Int -> Expr+      row k = ObjectLit [("k", IntLit (fromIntegral k))]+      -- (x) => { !constraint("applied"); $x.k }+      counting = Lambda ["x"] (Emit (Constrain "applied" []) (Path "x" ["k"]))+      -- (x) => { !constraint("applied", $x.k); $x.k }+      tracing = Lambda ["x"] (Emit (Constrain "applied" [Path "x" ["k"]]) (Path "x" ["k"]))+      sorting descending keys fn = ExpressionProgram (SortBy descending (ArrayLit (map row keys)) fn)+      applications descending keys = emittedConstraintCount defaultOptions Map.empty JNull (sorting descending keys counting)+      shuffled = [5, 3, 9, 1, 7, 3, 8, 2, 6, 4, 0, 5] :: [Int]++  it "is applied exactly once per element, whatever the order of the keys" $ do+    applications False shuffled `shouldBe` Right (length shuffled)+    applications False [1 .. 16] `shouldBe` Right 16+    applications False (reverse [1 .. 16]) `shouldBe` Right 16+    applications False (replicate 9 4) `shouldBe` Right 9++  it "is applied exactly once per element by the descending sort" $ do+    applications True shuffled `shouldBe` Right (length shuffled)+    applications True [1 .. 16] `shouldBe` Right 16++  it "is applied once to a single element, and not at all to an empty list" $ do+    applications False [7] `shouldBe` Right 1+    applications False [] `shouldBe` Right 0+    applications True [] `shouldBe` Right 0++  it "is applied in index order, not in the order of the result" $+    case runProgramWith defaultOptions {optMode = Symbolic} Map.empty JNull (sorting False [3, 1, 2] tracing) of+      Right (JObject o) -> do+        Map.lookup "root" o `shouldBe` Just (arr [object ["k" .= (1 :: Int)], object ["k" .= (2 :: Int)], object ["k" .= (3 :: Int)]])+        Map.lookup "constraints" o+          `shouldBe` Just (arr [object ["name" .= ("applied" :: Text), "arguments" .= [k]] | k <- [3, 1, 2 :: Int]])+      other -> expectationFailure ("expected a symbolic envelope object, got " <> show other)++  it "is not applied past the first element whose key is refused" $+    emittedConstraintCount+      defaultOptions+      Map.empty+      JNull+      (ExpressionProgram (SortBy False (ArrayLit [row 1, ObjectLit [("k", NullLit)], row 2]) counting))+      `shouldSatisfy` \case+        Left (TypeMismatch _) -> True+        _ -> False

@@ -0,0 +1,238 @@+-- | The typed JSON reader and writer, and what the number split asks of the+-- boundaries around them (@specs/reference.md@ \S3, @specs/node-json.md@+-- /Numbers/, @specs/decisions.md@ \S18). The shared corpus covers the+-- language-level behaviour; what is here is this port's own: the reader, the+-- writer, the aeson bridge and the 64-bit range.+module Tramaj.JsonSpec (spec) where++import qualified Data.Aeson as Aeson+import Data.Either (isLeft)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Test.Hspec+import Tramaj.Ast (Expr (..))+import Tramaj.Eval+import Tramaj.Json+import Tramaj.Node+import Tramaj.Parser (parseExpr, parseProgram)+import Tramaj.TestJson (object, (.=))++spec :: Spec+spec = describe "Tramaj.Json" $ do+  readerSpec+  writerSpec+  normalizeSpec+  bridgeSpec+  literalSpec+  contextSpec+  nodeSpec++readerSpec :: Spec+readerSpec = describe "jsonParser" $ do+  let reads' :: Text -> Json -> Spec+      reads' src expected = it (T.unpack src) (jsonParser src `shouldBe` Right expected)+      refuses :: Text -> Spec+      refuses src = it ("refuses " <> show src) (jsonParser src `shouldSatisfy` isLeft)++  describe "types a number by its text" $ do+    reads' "3" (JInt 3)+    reads' "-7" (JInt (-7))+    reads' "0" (JInt 0)+    reads' "-0" (JInt 0)+    reads' "3.0" (JFloat 3)+    reads' "3e0" (JFloat 3)+    reads' "3E0" (JFloat 3)+    reads' "1.5e3" (JFloat 1500)+    reads' "1e-7" (JFloat 1.0e-7)+    reads' "0.1" (JFloat 0.1)++  describe "keeps the digits of an integer, whatever its size" $ do+    reads' "9007199254740993" (JInt 9007199254740993)+    reads' "9223372036854775807" (JInt 9223372036854775807)+    reads' "-9223372036854775808" (JInt (-9223372036854775808))+    reads' "9223372036854775808" (JInt 9223372036854775808)+    reads' "123456789012345678901234567890" (JInt 123456789012345678901234567890)++  it "reads a float too large for a double as an infinity, for a decoder to refuse" $+    jsonParser "1e400" `shouldSatisfy` \case+      Right (JFloat d) -> isInfinite d+      _ -> False++  it "reads a float too small for a double as zero" $+    jsonParser "1e-400" `shouldBe` Right (JFloat 0)++  describe "reads every other JSON value" $ do+    reads' "null" JNull+    reads' "true" (JBool True)+    reads' " [1, 1.0, \"a\", null] " (JArray [JInt 1, JFloat 1, JString "a", JNull])+    reads' "{\"b\": {\"c\": 2.5}, \"a\": []}" (object ["a" .= ([] :: [Json]), "b" .= object ["c" .= (2.5 :: Double)]])+    reads' "\"a\\n\\u00e9\\ud83d\\ude00\"" (JString "a\n\233\128512")++  describe "refuses malformed JSON" $ do+    refuses ""+    refuses "[1,]"+    refuses "{\"a\": 1,}"+    refuses "01"+    refuses "1."+    refuses ".5"+    refuses "+1"+    refuses "1 2"+    refuses "nul"+    refuses "{\"a\" 1}"++writerSpec :: Spec+writerSpec = describe "stringify" $ do+  let writes :: Json -> Text -> Spec+      writes v expected = it (T.unpack expected) (stringify v `shouldBe` expected)++  describe "writes an integer as its digits" $ do+    writes (JInt 3) "3"+    writes (JInt (-7)) "-7"+    writes (JInt 100000000000) "100000000000"+    writes (JInt 9223372036854775807) "9223372036854775807"+    writes (JInt (-9223372036854775808)) "-9223372036854775808"++  describe "writes a float with a fraction or an exponent" $ do+    writes (JFloat 1) "1.0"+    writes (JFloat 0) "0.0"+    writes (JFloat (-2)) "-2.0"+    writes (JFloat 1.5) "1.5"+    writes (JFloat 0.1) "0.1"+    writes (JFloat 0.05) "0.05"+    writes (JFloat 100000000000) "100000000000.0"+    writes (JFloat 1.0e21) "1e+21"+    writes (JFloat 1.0e-7) "1e-7"+    writes (JFloat 1.5e-7) "1.5e-7"+    writes (JFloat 9.223372036854776e18) "9223372036854776000.0"++  describe "writes structures compactly, keys sorted" $ do+    writes (object ["b" .= (2 :: Int), "a" .= [JInt 1, JFloat 1, JNull, JBool False]]) "{\"a\":[1,1.0,null,false],\"b\":2}"+    writes (JString "a\"b\n") "\"a\\\"b\\n\""++  it "round-trips what it writes, type included" $+    let v = object ["n" .= (1 :: Int), "x" .= (1 :: Double), "big" .= JInt 9223372036854775807, "xs" .= [JFloat 1.0e21, JFloat 1.0e-7]]+     in jsonParser (stringify v) `shouldBe` Right v++normalizeSpec :: Spec+normalizeSpec = describe "normalizeNumbers" $ do+  it "keeps the two ends of the signed 64-bit range" $ do+    normalizeNumbers (JInt 9223372036854775807) `shouldBe` Right (JInt 9223372036854775807)+    normalizeNumbers (JInt (-9223372036854775808)) `shouldBe` Right (JInt (-9223372036854775808))++  it "refuses an integer one past either end, at any depth" $ do+    normalizeNumbers (JInt 9223372036854775808) `shouldSatisfy` isLeft+    normalizeNumbers (JInt (-9223372036854775809)) `shouldSatisfy` isLeft+    normalizeNumbers (object ["a" .= [object ["b" .= JInt 9223372036854775808]]]) `shouldSatisfy` isLeft++  it "refuses a float that is not finite" $ do+    normalizeNumbers (JFloat (1 / 0)) `shouldSatisfy` isLeft+    normalizeNumbers (JArray [JFloat (-1 / 0)]) `shouldSatisfy` isLeft++  it "turns a negative zero into zero" $+    fmap stringify (normalizeNumbers (JFloat (-0.0))) `shouldBe` Right "0.0"++  it "leaves a float beyond the integer range alone: it is a float by its text" $+    normalizeNumbers (JFloat 1.0e19) `shouldBe` Right (JFloat 1.0e19)++bridgeSpec :: Spec+bridgeSpec = describe "the aeson bridge" $ do+  it "reads a whole number in the integer range as an integer, any other as a float" $ do+    fromAeson (Aeson.Number 3) `shouldBe` JInt 3+    fromAeson (Aeson.Number 3.0) `shouldBe` JInt 3+    fromAeson (Aeson.Number 1.5) `shouldBe` JFloat 1.5+    fromAeson (Aeson.Number 9223372036854775807) `shouldBe` JInt 9223372036854775807+    fromAeson (Aeson.Number 9223372036854775808) `shouldBe` JFloat 9.223372036854775808e18++  it "gives the number type up on the way out" $ do+    toAeson (JInt 1) `shouldBe` Aeson.Number 1+    toAeson (JFloat 1) `shouldBe` Aeson.Number 1+    toAeson (object ["a" .= [JFloat 1.5]]) `shouldBe` Aeson.object ["a" Aeson..= [1.5 :: Double]]++literalSpec :: Spec+literalSpec = describe "number literals" $ do+  it "types a literal by its form" $ do+    parseExpr "1" `shouldBe` Right (IntLit 1)+    parseExpr "-7" `shouldBe` Right (IntLit (-7))+    parseExpr "1_000_000" `shouldBe` Right (IntLit 1000000)+    parseExpr "1.0" `shouldBe` Right (FloatLit 1)+    parseExpr "1e5" `shouldBe` Right (FloatLit 100000)+    parseExpr "-1.5" `shouldBe` Right (FloatLit (-1.5))++  it "accepts both ends of the signed 64-bit range" $ do+    parseExpr "9223372036854775807" `shouldBe` Right (IntLit maxBound)+    parseExpr "-9223372036854775808" `shouldBe` Right (IntLit minBound)++  it "refuses an integer literal one past either end" $ do+    parseExpr "9223372036854775808" `shouldSatisfy` isLeft+    parseExpr "-9223372036854775809" `shouldSatisfy` isLeft++  it "has no negative zero" $ do+    parseExpr "-0" `shouldBe` Right (IntLit 0)+    fmap show (parseExpr "-0.0") `shouldBe` Right (show (FloatLit 0))++contextSpec :: Spec+contextSpec = describe "the context boundary" $ do+  let run :: Mode -> Text -> Text -> Either String Text+      run mode src ctxText = do+        ctx <- jsonParser ctxText+        prog <- either (Left . show) Right (parseProgram src)+        either (Left . show) (Right . stringify) (runProgram mode Map.empty ctx prog)+      mismatch :: Mode -> Text -> Text -> Expectation+      mismatch mode src ctxText = do+        ctx <- either (\e -> fail ("fixture is not JSON: " <> e)) pure (jsonParser ctxText)+        prog <- either (\e -> fail ("fixture does not parse: " <> show e)) pure (parseProgram src)+        runProgram mode Map.empty ctx prog `shouldSatisfy` \case+          Left (TypeMismatch _) -> True+          _ -> False++  it "keeps the type each number was written with, through to the output" $+    run Concrete "[$ctx.a, $ctx.b, $ctx.c]" "{\"a\": 2, \"b\": 2.0, \"c\": 2e0}" `shouldBe` Right "[2,2.0,2.0]"++  it "holds a 64-bit integer exactly" $+    run Concrete "[$ctx.top, $ctx.bottom, str($ctx.top)]" "{\"top\": 9223372036854775807, \"bottom\": -9223372036854775808}"+      `shouldBe` Right "[9223372036854775807,-9223372036854775808,\"9223372036854775807\"]"++  it "refuses an integer outside the range, in both modes, read or not" $ do+    mismatch Concrete "$ctx.n" "{\"n\": 9223372036854775808}"+    mismatch Symbolic "$ctx.n" "{\"n\": -9223372036854775809}"+    mismatch Concrete "1" "{\"deep\": [{\"n\": 9223372036854775808}]}"++  it "refuses a float too large for a double, read or not" $ do+    mismatch Concrete "$ctx.x" "{\"x\": 1e400}"+    mismatch Symbolic "1" "{\"x\": -1e400}"++  it "reads a negative zero as the zero of its type" $+    run Concrete "[$ctx.a, $ctx.b, $ctx.c]" "{\"a\": -0, \"b\": -0.0, \"c\": -1e-400}" `shouldBe` Right "[0,0.0,0.0]"++  it "does not equate or compare an integer with a float" $ do+    run Concrete "[eq($ctx.a, $ctx.b), eq($ctx.a, 2), eq($ctx.b, 2.0)]" "{\"a\": 2, \"b\": 2.0}" `shouldBe` Right "[false,true,true]"+    mismatch Concrete "lt($ctx.a, $ctx.b)" "{\"a\": 2, \"b\": 2.5}"++  it "takes an integer as an index, never a float" $+    run Concrete "[lookup($ctx.xs, 1, \"d\"), lookup($ctx.xs, 1.0, \"d\"), has($ctx.xs, 1), has($ctx.xs, 1.0)]" "{\"xs\": [10, 20]}"+      `shouldBe` Right "[20,\"d\",true,false]"++  it "writes a float allocation key with its fraction in the symbol id" $+    run Symbolic "[?(1), ?(1.0)]" "null"+      `shouldSatisfy` either (const False) (\out -> "\"id\":\"#0:1\"" `T.isInfixOf` out && "\"id\":\"#1:1.0\"" `T.isInfixOf` out)++nodeSpec :: Spec+nodeSpec = describe "numbers in a Node" $ do+  let text v = object ["type" .= ("text" :: Text), "value" .= v, "annotations" .= object []]++  it "encodes an integer and a float as two different nodes" $ do+    stringify (nodeToJson (NText (JInt 3) noAnnotations)) `shouldBe` "{\"annotations\":{},\"type\":\"text\",\"value\":3}"+    stringify (nodeToJson (NText (JFloat 3) noAnnotations)) `shouldBe` "{\"annotations\":{},\"type\":\"text\",\"value\":3.0}"++  it "decodes each back as what it was" $ do+    (jsonParser "{\"type\":\"text\",\"value\":3,\"annotations\":{}}" >>= nodeFromJson) `shouldBe` Right (NText (JInt 3) noAnnotations)+    (jsonParser "{\"type\":\"text\",\"value\":3e0,\"annotations\":{}}" >>= nodeFromJson) `shouldBe` Right (NText (JFloat 3) noAnnotations)++  it "refuses an integer outside the range in a value, at any depth" $ do+    nodeFromJson (text (JInt 9223372036854775808)) `shouldSatisfy` isLeft+    nodeFromJson (text (object ["a" .= [JInt (-9223372036854775809)]])) `shouldSatisfy` isLeft++  it "keeps a 64-bit integer through a round trip" $+    let n = NElement "n" [NAttr "top" (JInt 9223372036854775807)] (JInt (-9223372036854775808)) [] noAnnotations+     in (jsonParser (stringify (nodeToJson n)) >>= nodeFromJson) `shouldBe` Right n

@@ -6,10 +6,12 @@ -- values of every JSON type. module Tramaj.NodeJsonSpec (spec) where -import Data.Aeson (ToJSON, Value (..), object, (.=)) import qualified Data.Map.Strict as Map+import Data.Text (Text) import Test.Hspec+import Tramaj.Json (Json (..)) import Tramaj.Node+import Tramaj.TestJson (ToJ, object, (.=))  spec :: Spec spec = describe "Tramaj.Node JSON representation" $ do@@ -21,39 +23,39 @@ -- | 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 a string", NText (JString "hello") noAnnotations)+  , ("text holding a number", NText (JInt 3) noAnnotations)+  , ("text holding null", NText JNull noAnnotations)+  , ("text holding a boolean", NText (JBool 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)+  , ("empty element", NElement "div" [] JNull [] noAnnotations)+  , ("element with an ordinary attribute", NElement "div" [NAttr "class" (JString "panel")] JNull [] noAnnotations)   ,     ( "element with several actions and attributes interleaved"     , NElement         "button"-        [ NAttr "class" (String "primary")+        [ NAttr "class" (JString "primary")         , NAction "on-click" "save" (object ["id" .= (1 :: Int)])-        , NAttr "data-n" (Number 2)-        , NAction "on-double-click" "open" Null+        , NAttr "data-n" (JInt 2)+        , NAction "on-double-click" "open" JNull         ]-        Null-        [NText (String "Save") noAnnotations]+        JNull+        [NText (JString "Save") noAnnotations]         noAnnotations     )-  , ("element with a value slot", NElement "Replicas" [] (Number 3) [] noAnnotations)-  , ("fragment", NFragment [NText (String "one") noAnnotations, NText (String "two") noAnnotations] noAnnotations)+  , ("element with a value slot", NElement "Replicas" [] (JInt 3) [] noAnnotations)+  , ("fragment", NFragment [NText (JString "one") noAnnotations, NText (JString "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)])])+        [NAttr "id" (JString "x")]+        JNull+        [NFragment [NText (JString "deep") (Map.fromList [("origin", JString "lib")])] (Map.fromList [("flattenable", JBool True)])]+        (Map.fromList [("type", JString "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)+  , ("repeated attribute names are preserved, not deduplicated", NElement "div" [NAttr "class" (JString "a"), NAttr "class" (JString "b")] JNull [] noAnnotations)   ]  roundTripSpec :: Spec@@ -66,41 +68,41 @@ 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 []]+    nodeToJson (NText (JInt 3) noAnnotations)+      `shouldBe` object ["type" .= ("text" :: Text), "value" .= (3 :: Int), "annotations" .= object []]    it "an element always emits tag, attributes, value, children and annotations" $-    nodeToJson (NElement "p" [] Null [] noAnnotations)+    nodeToJson (NElement "p" [] JNull [] noAnnotations)       `shouldBe` object-        [ "type" .= ("element" :: String)-        , "tag" .= ("p" :: String)-        , "attributes" .= ([] :: [Value])-        , "value" .= Null-        , "children" .= ([] :: [Value])+        [ "type" .= ("element" :: Text)+        , "tag" .= ("p" :: Text)+        , "attributes" .= ([] :: [Json])+        , "value" .= JNull+        , "children" .= ([] :: [Json])         , "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)+    nodeToJson (NElement "b" [NAttr "class" (JString "c"), NAction "on-click" "save" JNull] JNull [] noAnnotations)       `shouldBe` object-        [ "type" .= ("element" :: String)-        , "tag" .= ("b" :: String)+        [ "type" .= ("element" :: Text)+        , "tag" .= ("b" :: Text)         , "attributes"-            .= [ object ["kind" .= ("attribute" :: String), "name" .= ("class" :: String), "value" .= ("c" :: String)]-               , object ["kind" .= ("action" :: String), "event" .= ("on-click" :: String), "key" .= ("save" :: String), "payload" .= Null]+            .= [ object ["kind" .= ("attribute" :: Text), "name" .= ("class" :: Text), "value" .= ("c" :: Text)]+               , object ["kind" .= ("action" :: Text), "event" .= ("on-click" :: Text), "key" .= ("save" :: Text), "payload" .= JNull]                ]-        , "value" .= Null-        , "children" .= ([] :: [Value])+        , "value" .= JNull+        , "children" .= ([] :: [Json])         , "annotations" .= object []         ]    it "a fragment emits no tag, attributes or value" $     nodeToJson (NFragment [] noAnnotations)-      `shouldBe` object ["type" .= ("fragment" :: String), "children" .= ([] :: [Value]), "annotations" .= object []]+      `shouldBe` object ["type" .= ("fragment" :: Text), "children" .= ([] :: [Json]), "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+-- Malformed documents are built as 'Json'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@@ -110,54 +112,54 @@   rejects "a node with no type" $     object ["value" .= (1 :: Int), "annotations" .= object []]   rejects "an unknown node type" $-    object ["type" .= ("comment" :: String), "annotations" .= object []]+    object ["type" .= ("comment" :: Text), "annotations" .= object []]   rejects "a text node with no value" $-    object ["type" .= ("text" :: String), "annotations" .= object []]+    object ["type" .= ("text" :: Text), "annotations" .= object []]   rejects "a node with no annotations" $-    object ["type" .= ("text" :: String), "value" .= (1 :: Int)]+    object ["type" .= ("text" :: Text), "value" .= (1 :: Int)]   rejects "an element with no value slot" $     object-      [ "type" .= ("element" :: String)-      , "tag" .= ("p" :: String)-      , "attributes" .= ([] :: [Value])-      , "children" .= ([] :: [Value])+      [ "type" .= ("element" :: Text)+      , "tag" .= ("p" :: Text)+      , "attributes" .= ([] :: [Json])+      , "children" .= ([] :: [Json])       , "annotations" .= object []       ]   rejects "an element with a non-string tag" $-    element (Number 1) ([] :: [Value]) ([] :: [Value])+    element (JInt 1) ([] :: [Json]) ([] :: [Json])   rejects "an element whose children are not an array" $-    element (String "p") ([] :: [Value]) (object [])+    element (JString "p") ([] :: [Json]) (object [])   rejects "an element whose attributes are not an array" $-    element (String "p") (object []) ([] :: [Value])+    element (JString "p") (object []) ([] :: [Json])   rejects "annotations that are not an object" $-    object ["type" .= ("fragment" :: String), "children" .= ([] :: [Value]), "annotations" .= ([] :: [Value])]+    object ["type" .= ("fragment" :: Text), "children" .= ([] :: [Json]), "annotations" .= ([] :: [Json])]   rejects "an attribute with no kind" $-    element (String "p") [object ["name" .= ("a" :: String), "value" .= (1 :: Int)]] ([] :: [Value])+    element (JString "p") [object ["name" .= ("a" :: Text), "value" .= (1 :: Int)]] ([] :: [Json])   rejects "an unknown attribute kind" $-    element (String "p") [object ["kind" .= ("listener" :: String)]] ([] :: [Value])+    element (JString "p") [object ["kind" .= ("listener" :: Text)]] ([] :: [Json])   rejects "an action with no key" $-    element (String "p") [object ["kind" .= ("action" :: String), "event" .= ("e" :: String), "payload" .= Null]] ([] :: [Value])+    element (JString "p") [object ["kind" .= ("action" :: Text), "event" .= ("e" :: Text), "payload" .= JNull]] ([] :: [Json])   rejects "an attribute with a non-string name" $-    element (String "p") [object ["kind" .= ("attribute" :: String), "name" .= (1 :: Int), "value" .= Null]] ([] :: [Value])+    element (JString "p") [object ["kind" .= ("attribute" :: Text), "name" .= (1 :: Int), "value" .= JNull]] ([] :: [Json])   rejects "a malformed node nested deep in a child" $     object-      [ "type" .= ("fragment" :: String)-      , "children" .= [object ["type" .= ("text" :: String)]]+      [ "type" .= ("fragment" :: Text)+      , "children" .= [object ["type" .= ("text" :: Text)]]       , "annotations" .= object []       ]-  rejects "a bare scalar where a node was expected" $ Number 42+  rejects "a bare scalar where a node was expected" $ JInt 42   rejects "an attribute that is not an object" $-    element (String "p") [String "class"] ([] :: [Value])+    element (JString "p") [JString "class"] ([] :: [Json])   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 :: (ToJ a, ToJ b) => Json -> a -> b -> Json     element tag attrs children =       object-        [ "type" .= ("element" :: String)+        [ "type" .= ("element" :: Text)         , "tag" .= tag         , "attributes" .= attrs-        , "value" .= Null+        , "value" .= JNull         , "children" .= children         , "annotations" .= object []         ]@@ -175,25 +177,25 @@       ( NElement           "div"           []-          Null-          [NFragment [NElement "b" [NAction "on-click" "save" Null] Null [] noAnnotations] noAnnotations]+          JNull+          [NFragment [NElement "b" [NAction "on-click" "save" JNull] JNull [] noAnnotations] noAnnotations]           noAnnotations       )       `shouldBe` Right         ( NElement             "div"             []-            Null-            [NFragment [NElement "b" [NAction "on-click" "ns:save" Null] Null [] noAnnotations] noAnnotations]+            JNull+            [NFragment [NElement "b" [NAction "on-click" "ns:save" JNull] JNull [] 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+    let anns = Map.fromList [("origin", JString "lib")]+        n = NElement "div" [NAttr "class" (JString "c"), NAction "on-click" "save" JNull] (JInt 1) [] anns      in prefix "ns:" n-          `shouldBe` Right (NElement "div" [NAttr "class" (String "c"), NAction "on-click" "ns:save" Null] (Number 1) [] anns)+          `shouldBe` Right (NElement "div" [NAttr "class" (JString "c"), NAction "on-click" "ns:save" JNull] (JInt 1) [] anns)    it "propagates a failing rewrite instead of dropping it" $-    mapActions (\_ _ _ -> Left "boom") (NElement "b" [NAction "on-click" "save" Null] Null [] noAnnotations)+    mapActions (\_ _ _ -> Left "boom") (NElement "b" [NAction "on-click" "save" JNull] JNull [] noAnnotations)       `shouldBe` (Left "boom" :: Either String Node)

@@ -80,6 +80,16 @@   -- meaningless Call that only fails much later.   rejects "a malformed import" "import(\"lib\")"   rejects "a malformed map" "map($xs)"+  -- reference.md \S5: a sort takes exactly two arguments, under both names+  -- and both spellings.+  rejects "a sort with one argument" "sort-by($xs)"+  rejects "a sort with three arguments" "sort-by($xs, (x) => $x, true)"+  rejects "a sort with no argument" "sort-by()"+  rejects "a descending sort with one argument" "sort-by-descending($xs)"+  rejects "a descending sort with three arguments" "sort-by-descending($xs, (x) => $x, true)"+  rejects "a dollar-spelled sort with one argument" "$sort-by($xs)"+  -- Being recognized by the parser, the name cannot be passed by reference.+  rejects "a sort passed by reference" "map($xs, $sort-by)"   rejects "import parameters that are not a parameter list" "import(\"lib\", $ctx)"    rejects "an unknown escape sequence" "\"a\\qb\""@@ -169,15 +179,31 @@    parsesTo "an empty string" "\"\"" (StringLit "") +  -- reference.md \S2, \S5: the two sort names lower to the one constructor.   parsesTo+    "sort-by into SortBy, ascending"+    "sort-by($xs, (x) => $x.k)"+    (SortBy False (Path "xs" []) (Lambda ["x"] (Path "x" ["k"])))++  parsesTo+    "sort-by-descending into the same constructor, descending"+    "sort-by-descending($xs, $key-of)"+    (SortBy True (Path "xs" []) (Path "key-of" []))++  parsesTo+    "the dollar spelling of a sort into the same form"+    "$sort-by($xs, $str)"+    (SortBy False (Path "xs" []) (Path "str" []))++  parsesTo     "object shorthand into an explicit field reading the same name"     "{foo, bar: 1}"-    (ObjectLit [("foo", Path "foo" []), ("bar", NumberLit 1)])+    (ObjectLit [("foo", Path "foo" []), ("bar", IntLit 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)))+    (Branch (Path "a" []) (IntLit 1) (Branch (Path "b" []) (IntLit 2) (IntLit 0)))    parsesTo     "concat as a left-associative chain"@@ -194,8 +220,8 @@     ".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)+        [Attr "class" (StringLit "a"), ActionAttr "on-click" "save" (IntLit 1)]+        (IntLit 2)         [StringLit "kid"]     ) @@ -224,7 +250,7 @@   parsesTo     "a field access on a call's result into FieldAccess"     "$f(1).rendered"-    (FieldAccess (Call (Path "f" []) [NumberLit 1]) ["rendered"])+    (FieldAccess (Call (Path "f" []) [IntLit 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" []])@@ -233,7 +259,7 @@     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" []])))+            (Let "a" (IntLit 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@@ -264,16 +290,16 @@    declares     "a record declaration"-    "type Point = { x : number, y : number }\ntrue"-    (ExpressionProgram (TypeDecl "Point" (TRecord [("x", TPrim "number"), ("y", TPrim "number")]) (BoolLit True)))+    "type Point = { x : float, y : float }\ntrue"+    (ExpressionProgram (TypeDecl "Point" (TRecord [("x", TPrim "float"), ("y", TPrim "float")]) (BoolLit True)))    declares     "a union declaration with payload-carrying and nullary arms"-    "type Shape = | Circle { r : number } | Dev\ntrue"+    "type Shape = | Circle { r : float } | Dev\ntrue"     ( ExpressionProgram         ( TypeDecl             "Shape"-            (TUnion [("Circle", Just (TRecord [("r", TPrim "number")])), ("Dev", Nothing)])+            (TUnion [("Circle", Just (TRecord [("r", TPrim "float")])), ("Dev", Nothing)])             (BoolLit True)         )     )@@ -320,8 +346,8 @@         ( DocumentProgram             ( Let                 "a"-                (NumberLit 1)-                (TypeDecl "T" (TPrim "string") (Let "b" (NumberLit 2) (Element "p" [] NullLit [StringLit "x"])))+                (IntLit 1)+                (TypeDecl "T" (TPrim "string") (Let "b" (IntLit 2) (Element "p" [] NullLit [StringLit "x"])))             )         ) @@ -350,7 +376,7 @@   declares     "an annotation naming a library-qualified type"     "@m : $msg.types.Envelope = 1\ntrue"-    (ExpressionProgram (TypeAnnotate "m" (TLibRef "msg" "Envelope") (NumberLit 1) (BoolLit True)))+    (ExpressionProgram (TypeAnnotate "m" (TLibRef "msg" "Envelope") (IntLit 1) (BoolLit True)))    -- roadmap Phase 12: !type-constraint.   declares@@ -372,4 +398,4 @@    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)))+      `shouldBe` Right (ExpressionProgram (Emit (Constrain "k" [IntLit 1]) (BoolLit True)))

@@ -0,0 +1,41 @@+-- | Builders for 'Json' fixtures, so a spec can spell an object as a list of+-- @key .= value@ pairs. A Haskell 'Int' becomes an integer and a 'Double' a+-- float, which is the host binding these specs use throughout.+module Tramaj.TestJson+  ( ToJ (..)+  , object+  , (.=)+  ) where++import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Tramaj.Json (Json (..))++class ToJ a where+  toJ :: a -> Json++instance ToJ Json where+  toJ = id++instance ToJ Int where+  toJ = JInt . toInteger++instance ToJ Double where+  toJ = JFloat++instance ToJ Bool where+  toJ = JBool++instance ToJ Text where+  toJ = JString++instance (ToJ a) => ToJ [a] where+  toJ = JArray . map toJ++object :: [(Text, Json)] -> Json+object = JObject . Map.fromList++infixr 8 .=++(.=) :: (ToJ a) => Text -> a -> (Text, Json)+k .= v = (k, toJ v)

@@ -48,12 +48,12 @@    resolvesTo     Map.empty-    (prog "type Inner = { x : number }\ntype Outer = { items : [ Inner ] }\ntrue")+    (prog "type Inner = { x : int }\ntype Outer = { items : [ Inner ] }\ntrue")     "Outer"     "{items:[root:Inner]}"    resolvesTo-    (Map.fromList [("message", prog "type Envelope = { to : string, id : number }\ntrue")])+    (Map.fromList [("message", prog "type Envelope = { to : string, id : int }\ntrue")])     (prog "@msg=import(\"message\", {})\ntype UsesEnvelope = { env : $msg.types.Envelope }\ntrue")     "UsesEnvelope"     "{env:\"message\":Envelope}"@@ -63,9 +63,9 @@   -- author happened to write things in.   resolvesTo     Map.empty-    (prog "type Shape = | Square { s : number } | Circle { r : number } | Dev\ntrue")+    (prog "type Shape = | Square { s : float } | Circle { r : float } | Dev\ntrue")     "Shape"-    "|Circle {r:number}|Dev|Square {s:number}"+    "|Circle {r:float}|Dev|Square {s:float}"    -- A root declaration and a same-named library declaration must render to   -- different strings -- the whole point of \"root\" being a token no

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               tramaj-hs-version:            0.3.0.0+version:            0.4.0.0 synopsis:           Haskell parser/AST/evaluator for the tramaj language description:   Parser, AST and evaluator for the tramaj language specified in@@ -46,12 +46,13 @@     Tramaj.Analysis     Tramaj.Ast     Tramaj.Eval+    Tramaj.Json     Tramaj.Node     Tramaj.Parser     Tramaj.Types   build-depends:     , base            >=4.19  && <4.22-    , aeson           >=2.1   && <2.4+    , aeson           >=2.2.1 && <2.4     , containers      >=0.6   && <0.9     , megaparsec      >=9.5   && <9.9     , scientific      >=0.3   && <0.4@@ -67,8 +68,10 @@     Tramaj.AnalysisSpec     Tramaj.CorpusSpec     Tramaj.EvalSpec+    Tramaj.JsonSpec     Tramaj.NodeJsonSpec     Tramaj.ParserSpec+    Tramaj.TestJson     Tramaj.TypesSpec   build-depends:     , base