diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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": , "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 diff --git a/src/Tramaj/Analysis.hs b/src/Tramaj/Analysis.hs --- a/src/Tramaj/Analysis.hs +++ b/src/Tramaj/Analysis.hs @@ -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 ----------------------------------------------------------------------- diff --git a/src/Tramaj/Ast.hs b/src/Tramaj/Ast.hs --- a/src/Tramaj/Ast.hs +++ b/src/Tramaj/Ast.hs @@ -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 diff --git a/src/Tramaj/Eval.hs b/src/Tramaj/Eval.hs --- a/src/Tramaj/Eval.hs +++ b/src/Tramaj/Eval.hs @@ -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\": , \"path\": [, ...]}") - | 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\": , \"path\": [, ...]}") + | 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\": , \"arguments\": [, ...]}") + | 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 diff --git a/src/Tramaj/Json.hs b/src/Tramaj/Json.hs new file mode 100644 --- /dev/null +++ b/src/Tramaj/Json.hs @@ -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))) diff --git a/src/Tramaj/Node.hs b/src/Tramaj/Node.hs --- a/src/Tramaj/Node.hs +++ b/src/Tramaj/Node.hs @@ -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 diff --git a/src/Tramaj/Parser.hs b/src/Tramaj/Parser.hs --- a/src/Tramaj/Parser.hs +++ b/src/Tramaj/Parser.hs @@ -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 diff --git a/src/Tramaj/Types.hs b/src/Tramaj/Types.hs --- a/src/Tramaj/Types.hs +++ b/src/Tramaj/Types.hs @@ -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 diff --git a/test/unit/Tramaj/AnalysisSpec.hs b/test/unit/Tramaj/AnalysisSpec.hs --- a/test/unit/Tramaj/AnalysisSpec.hs +++ b/test/unit/Tramaj/AnalysisSpec.hs @@ -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 diff --git a/test/unit/Tramaj/CorpusSpec.hs b/test/unit/Tramaj/CorpusSpec.hs --- a/test/unit/Tramaj/CorpusSpec.hs +++ b/test/unit/Tramaj/CorpusSpec.hs @@ -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 \@, 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 diff --git a/test/unit/Tramaj/EvalSpec.hs b/test/unit/Tramaj/EvalSpec.hs --- a/test/unit/Tramaj/EvalSpec.hs +++ b/test/unit/Tramaj/EvalSpec.hs @@ -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 diff --git a/test/unit/Tramaj/JsonSpec.hs b/test/unit/Tramaj/JsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/JsonSpec.hs @@ -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 diff --git a/test/unit/Tramaj/NodeJsonSpec.hs b/test/unit/Tramaj/NodeJsonSpec.hs --- a/test/unit/Tramaj/NodeJsonSpec.hs +++ b/test/unit/Tramaj/NodeJsonSpec.hs @@ -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) diff --git a/test/unit/Tramaj/ParserSpec.hs b/test/unit/Tramaj/ParserSpec.hs --- a/test/unit/Tramaj/ParserSpec.hs +++ b/test/unit/Tramaj/ParserSpec.hs @@ -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))) diff --git a/test/unit/Tramaj/TestJson.hs b/test/unit/Tramaj/TestJson.hs new file mode 100644 --- /dev/null +++ b/test/unit/Tramaj/TestJson.hs @@ -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) diff --git a/test/unit/Tramaj/TypesSpec.hs b/test/unit/Tramaj/TypesSpec.hs --- a/test/unit/Tramaj/TypesSpec.hs +++ b/test/unit/Tramaj/TypesSpec.hs @@ -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 diff --git a/tramaj-hs.cabal b/tramaj-hs.cabal --- a/tramaj-hs.cabal +++ b/tramaj-hs.cabal @@ -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