tramaj-hs-0.4.0.0: src/Tramaj/Eval.hs
{-# LANGUAGE CPP #-}
-- | Evaluates a "Tramaj.Ast" 'Program' against an input context, producing
-- either a "Tramaj.Node" document or an ordinary JSON value.
--
-- There is one evaluator. v1 had two -- an expression evaluator and a
-- template-node evaluator -- because it had two ASTs; now that documents are
-- expressions, 'evalExpr' handles everything, and the only rule the document
-- side adds is how a child value becomes children ('childNodes').
--
-- 'Value'' is the language's full value domain, not JSON with extras bolted
-- on: an array or object may contain document nodes, which is what makes the
-- JSX-children pattern -- passing a fragment to a component as an ordinary
-- parameter -- work without a separate template-value category. JSON is what
-- you get at the boundaries ('toJson'), where a node would be meaningless: an
-- attribute value, an action payload, an element's value slot.
--
-- Evaluation is eager and deterministic everywhere except 'Branch', which
-- evaluates only the arm it selects.
module Tramaj.Eval
( EvalError (..)
, Output (..)
, Mode (..)
, Options (..)
, defaultOptions
, LibraryTable
, evalProgram
, evalProgramWith
, runProgram
, runProgramWith
, evalExprWith
, emittedConstraintCount
, builtinNames
) where
import Control.Monad (foldM)
import Data.Bifunctor (first)
import Data.Foldable (traverse_)
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.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
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)
data EvalError
= UnboundName Text
| PathNotFound [Text]
| TypeMismatch Text
| UnknownLibrary Text
| ImportCycle Text
| -- | @a \<\> b@ where the two sides are not the same concatenable type.
ConcatMismatch Text Text
| -- | Whatever went wrong inside an imported library, tagged with which
-- library it was. Nests, so a failure three imports deep reads as the
-- chain that reached it. This matters most for the parameter a library
-- needs and the import never supplied: that surfaces as this library's
-- own @PathNotFound ["ctx", ...]@, and without the tag there would be
-- nothing on it to say whose context was short.
InLibrary Text EvalError
| -- | A symbol would have to be minted in concrete mode: an allocation
-- (@?(k)@, v3-symbols \S4) or an unsupplied @?ctx.path@ demand at the root
-- (\S1.3). Concrete mode has no way to represent either. Symbolic mode
-- never raises it: that is the one mode where a symbol is representable.
SymbolsUnavailable
| -- | A symbolic value where the language requires a concrete one (\S1.5's
-- table, and a symbol used as an allocation key).
NotConcrete Text
| -- | A program containing @?(k)@ is loaded as a library (\S1.4): only the
-- root may allocate, because the root runs exactly once and a library
-- does not. Lexical, not data-flow -- raised because the library's own
-- source contains an allocation site, whether or not evaluation would
-- ever reach it.
AllocationInLibrary Text
| -- | A static v4-types failure (v4-types \S10), surfaced from either the
-- erasure pass every entry point below runs before evaluating anything
-- (\S7, roadmap Phase 11) or from building the symbolic envelope's
-- @\"types\"@\/@\"type-constraints\"@ lists (\S8, Phase 13). Not a new
-- evaluation failure mode -- nothing here is raised /during/ evaluation
-- -- but 'Tramaj.Types.TypeError' still needs a home in the one error
-- type every entry point already returns.
TypeErr TypeError
| -- | 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
-- actually evaluated to, not from how the root was written: a program whose
-- root is @$header@ yields a document if that binding holds one.
data Output
= ONode Node
| OValue Json
deriving stock (Eq, Show)
-- | A host parameter, not a property of the program (v3-symbols \S5): what an
-- interpreter is willing to read back out, not anything the template itself
-- declares. 'Concrete' is @reference.md@ exactly -- Node JSON or a plain
-- value, byte for byte. 'Symbolic' wraps the same evaluation in the v3
-- envelope (\S5.2); until \S3\/\S4 land, that envelope's @"symbols"@ and
-- @"constraints"@ are always empty, because nothing yet produces either.
data Mode = Concrete | Symbolic
deriving stock (Eq, Show)
-- | 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'.
type LibraryTable = Map Text Program
-- | The language's value domain.
--
-- 'VArray'\/'VObject' hold 'Value'', not JSON, so a document node can travel
-- inside a structure like any other value. 'VEnv' is an import's
-- @{rendered, vals}@ result. 'VImport' is an import that has been wired up but
-- not run -- reading a field off it is what runs it.
--
-- There is no recursion: 'Let' inserts a binding only after evaluating its
-- right-hand side, so a closure cannot see its own name.
--
-- 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
| VInt Int64
| VFloat Double
| VString Text
| VArray [Value']
| VObject (Map Text Value')
| VNode' Node
| VClosure [Text] Expr Env
| VBuiltin Text
| VEnv Env
| VImport Pending
| -- | @constraint(name, args...)@ (v3-symbols \S2.1): a value like any
-- other, so it can be bound, passed around and collected into an array,
-- right up until it tries to cross a JSON boundary ('toJson' refuses it)
-- or is left unreached by any @!@.
VConstraint Text [Value']
| -- | A symbol (\S1.1): opaque data, identified by 'SymbolId' and a
-- projection path extended one segment at a time by field access
-- (\S1.6). An allocation (@?(k)@) starts with an empty path; so does a
-- demand (@?ctx.path@) once minted -- its own path is baked into the id,
-- not carried here.
VSymbol SymbolId [Text]
| -- | 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'
-- | A symbol's identity (\S1.4): a string, identical in every conforming
-- implementation for the same program and key. Kept distinct from 'Text'
-- only so the two forms ('renderAllocId', 'renderDemandId') stay the only
-- places one is built.
type SymbolId = Text
-- | An entry in the symbol table (\S5.2). Only allocations appear there --
-- which includes an unsupplied demand minted at the root (\S1.3), since
-- that too is the root allocating -- and a symbol the host seeded (\S5.4)
-- is never listed, because the language has nothing to add about one it
-- did not mint.
data SymbolEntry = SymbolEntry
{ seId :: SymbolId
, seOrigin :: SymbolOrigin
, seBinding :: Maybe Text
}
deriving stock (Eq, Show)
-- | Where a symbol table entry came from: an @?(k)@ at a given site, with
-- the key it was allocated with already reduced to JSON; or an unsupplied
-- @?ctx.path@ demand, minted at the root.
data SymbolOrigin
= OAlloc Int Json
| ODemand [Text]
deriving stock (Eq, Show)
-- | An import that has been named and wired up, and has not run.
--
-- @pParams@ is everything supplied so far, however it arrived: an expression,
-- a @ctx(path)@ read out of the importing program's own context at the wiring
-- site, or a later call adding more. Nothing here records what is still
-- /missing/, because nothing here knows: the library decides that when it runs
-- and reads its @$ctx@. That is the whole point of the design -- an omitted
-- parameter is what defers an import, so partiality needs no declaration and
-- no bookkeeping.
--
-- @pQueued@ holds adaptations applied before the import ran; they run on the
-- result, once there are actions for them to reach.
data Pending = Pending
{ pName :: Text
, pParams :: Map Text Value'
, pQueued :: [(ActionAdaptation, Maybe Value')]
}
-- | Everything evaluation needs to know about that is not the local
-- environment: the library table, the set of libraries already being
-- evaluated on this chain (cycle detection), the mode (v3-symbols \S5), and
-- whether this is the root program or somewhere inside a library (\S1.3,
-- \S1.4) -- bundled so that adding one more such fact, as \S1.4's did,
-- touches this record instead of every function's argument list.
-- '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
-- cycle, not a loop) and clears 'ecIsRoot' -- a library never allocates or
-- mints (\S1.3, \S1.4), no matter how deep the chain that reached it.
enterLibrary :: Text -> EvalCtx -> EvalCtx
enterLibrary name ctx = ctx {ecInProgress = Set.insert name (ecInProgress ctx), ecIsRoot = False}
-- | What evaluation accumulates alongside its result (v3-symbols \S4):
-- emitted constraints and allocated symbol-table entries, each in
-- evaluation order and each deduplicated only once, globally, at the top
-- (\S4 -- "first position kept") rather than on every append.
data Emissions = Emissions
{ emConstraints :: [Value']
, emSymbols :: [SymbolEntry]
}
instance Semigroup Emissions where
Emissions c1 s1 <> Emissions c2 s2 = Emissions (c1 <> c2) (s1 <> s2)
instance Monoid Emissions where
mempty = Emissions [] []
-- The evaluation monad -------------------------------------------------------
-- | Evaluation threads two things besides the value it produces: it can fail
-- with an 'EvalError', and it accumulates 'Emissions' monoidally -- appended
-- in evaluation order, never mutated in place, so 'Branch' evaluating only
-- its selected arm gives exactly the right emission set for free, with no
-- separate mechanism.
newtype Eval a = MkEval {runEval :: Either EvalError (a, Emissions)}
instance Functor Eval where
fmap f (MkEval e) = MkEval (fmap (\(a, w) -> (f a, w)) e)
instance Applicative Eval where
pure a = MkEval (Right (a, mempty))
MkEval mf <*> MkEval ma = MkEval $ do
(f, w1) <- mf
(a, w2) <- ma
pure (f a, w1 <> w2)
instance Monad Eval where
MkEval ma >>= f = MkEval $ do
(a, w1) <- ma
(b, w2) <- runEval (f a)
pure (b, w1 <> w2)
evalError :: EvalError -> Eval a
evalError e = MkEval (Left e)
-- | Brings a pure, non-emitting computation into 'Eval' -- every helper that
-- only inspects already-evaluated 'Value''s (no 'Expr' to evaluate, so
-- nothing it could emit) stays plain 'Either' and is lifted at the call site.
liftEither :: Either EvalError a -> Eval a
liftEither = MkEval . fmap (,mempty)
-- | Records constraints reached by a @!@ (v3-symbols \S2.2), in the order
-- given.
tellConstraints :: [Value'] -> Eval ()
tellConstraints vs = MkEval (Right ((), mempty {emConstraints = vs}))
-- | Records one symbol-table entry, minted by an allocation or an
-- unsupplied demand at the root (\S1.3, \S5.2).
tellSymbol :: SymbolEntry -> Eval ()
tellSymbol entry = MkEval (Right ((), mempty {emSymbols = [entry]}))
-- | Maps over the error only, leaving any emissions already accumulated
-- alone -- 'InLibrary'\'s tag, applied the same way 'Data.Bifunctor.first'
-- tags a plain 'Either'.
mapEvalError :: (EvalError -> EvalError) -> Eval a -> Eval a
mapEvalError f (MkEval e) = MkEval (first f e)
foldlEval :: (b -> a -> Eval b) -> b -> [a] -> Eval b
foldlEval f = go
where
go acc [] = pure acc
go acc (x : xs) = f acc x >>= \acc' -> go acc' xs
-- Entry points ---------------------------------------------------------------
-- | Evaluation now depends on the mode (v3-symbols \S5): an allocation or an
-- unsupplied root demand mints a symbol in symbolic mode and raises
-- 'SymbolsUnavailable' in concrete mode. There is no mode-independent
-- evaluation any more, so every entry point takes one.
evalProgram :: Mode -> LibraryTable -> 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 :: 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
-- equality is on the already-evaluated 'Value'', which is why this must run
-- after evaluation rather than being folded into 'tellConstraints' -- two
-- constraints built from different expressions can still evaluate to the
-- same fact.
dedupe :: Emissions -> Emissions
dedupe (Emissions cs ss) = Emissions (dedupeBy constraintEq cs) (dedupeBy (\a b -> seId a == seId b) ss)
where
dedupeBy eq = go []
where
go _ [] = []
go seen (x : xs)
| any (eq x) seen = go seen xs
| otherwise = x : go (x : seen) xs
-- | Structural equality restricted to what a constraint's identity is made
-- of: its name and its arguments, each compared as the JSON they will
-- render as. Two constraints are the same fact regardless of which
-- expressions produced them.
constraintEq :: Value' -> Value' -> Bool
constraintEq (VConstraint n1 as1) (VConstraint n2 as2) =
n1 == n2 && length as1 == length as2 && and (zipWith argEq as1 as2)
where
argEq a b = case (toJson a, toJson b) of
(Right ja, Right jb) -> ja == jb
_ -> False
constraintEq _ _ = False
-- | The mode-aware entry point: what a host actually serializes. Concrete
-- mode is 'evalProgram' unchanged, projected down to plain JSON -- Node JSON
-- for a document, the value itself for an expression, with any emissions
-- discarded (v3-symbols \S5.1). Symbolic mode wraps the same 'Output' in the
-- v3 envelope (\S5.2), including the deduplicated symbol table and
-- constraint list.
runProgram :: Mode -> LibraryTable -> 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 (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/
-- erasure -- unlike evaluation, which never needs a 'TypeAnnotate' or
-- 'TypeEmit' once erasure has run, this is the one place they still matter:
-- the envelope is exactly where a host needs the definitions and constraints
-- those nodes named. Concrete mode never calls this ('runProgram' short-
-- circuits it), matching \S8's promise that a v3 consumer reading a v4
-- envelope sees nothing new.
buildTypesInfo :: LibraryTable -> Program -> Either TypeError (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])])
buildTypesInfo libs prog = do
roots <- programTypeRoots libs prog
closure <- typeClosure libs prog roots
tcs <- deepTypeConstraints libs prog
pure (closure, tcs)
renderOutput :: Mode -> (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])]) -> (Output, Emissions) -> Json
renderOutput Concrete _ (output, _) = case output of
ONode n -> nodeToJson n
OValue v -> v
renderOutput Symbolic (typesTable, typeConstraintsList) (output, Emissions constraints symbols) =
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) -> Json
typeEntryToJson (tid, 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 -> 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 [("kind", JString "record"), ("fields", JArray (map field fields))]
where
field (name, t) = object [("name", JString name), ("type", resolvedTypeToJson t)]
resolvedTypeToJson (RUnion arms) =
object [("kind", JString "union"), ("arms", JArray (map arm arms))]
where
arm (name, mt) =
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]) -> Json
typeConstraintToJson (name, args) =
object [("name", JString name), ("arguments", JArray (map arg args))]
where
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' -> Json
constraintToJson (VConstraint name args) =
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 -> Json
symbolEntryToJson (SymbolEntry sid origin binding) =
object
[ ("id", JString sid)
, ("origin", originToJson origin)
, ("binding", maybe JNull JString binding)
]
where
originToJson (OAlloc site key) =
object [("kind", JString "alloc"), ("site", JInt (toInteger site)), ("key", key)]
originToJson (ODemand 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'. Runs without the arithmetic profile,
-- as 'evalProgram' does.
evalExprWith :: Mode -> LibraryTable -> Value' -> Expr -> Either EvalError Value'
evalExprWith mode libs ctx e =
fst <$> runEval (evalExpr (rootCtx options libs) (initialEnv (optArithmetic options) ctx) e)
where
options = defaultOptions {optMode = mode}
-- | 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
}
-- | @$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"
, "count"
, "str"
, "not"
, "and"
, "or"
, "eq"
, "lt"
, "lte"
, "gt"
, "gte"
, "has"
, "lookup"
, "format-number"
, "concat"
, "append"
]
-- Core evaluation ------------------------------------------------------------
evalExpr :: EvalCtx -> Env -> Expr -> Eval Value'
evalExpr ctx env (Path root fields) = case Map.lookup root env of
Nothing -> evalError (UnboundName root)
Just v -> walkFields ctx (root : fields) v fields
evalExpr ctx env (FieldAccess target fields) = do
v <- evalExpr ctx env target
walkFields ctx fields v fields
evalExpr ctx env (Call fnExpr argExprs) = do
fnVal <- evalExpr ctx env fnExpr
argVals <- traverse (evalExpr ctx env) argExprs
apply ctx (describeCallee fnExpr) fnVal argVals
evalExpr _ env (Lambda params body) = pure (VClosure params body env)
-- | @\@name=?(k)@ or @\@name=?ctx.path@ binds the allocation\/demand directly
-- to a name, which is what the symbol table's @"binding"@ field (\S5.2)
-- reports; anything else evaluates exactly as it always has. Routed through
-- 'evalBindable' rather than special-cased here so a standalone 'Alloc'\/
-- 'Demand' (used inline, with no binding) shares the same minting logic.
evalExpr ctx env (Let name valueExpr body) = do
v <- evalBindable ctx env (if isHiddenName name then Nothing else Just name) valueExpr
evalExpr ctx (Map.insert name v env) body
evalExpr _ _ (StringLit s) = pure (VString s)
evalExpr _ _ (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) =
VArray <$> traverse (evalExpr ctx env) elems
evalExpr ctx env (ObjectLit entries) =
VObject . Map.fromList <$> traverse (\(k, e) -> (,) k <$> evalExpr ctx env e) entries
evalExpr ctx env (Element tag attrs valExpr children) = do
attrs' <- traverse (evalAttribute ctx env) attrs
val <- evalExpr ctx env valExpr >>= liftEither . toJson
children' <- evalChildren ctx env children
pure (VNode' (NElement tag attrs' val children' noAnnotations))
evalExpr ctx env (Fragment children) =
VNode' . flip NFragment noAnnotations <$> evalChildren ctx env children
-- | The one non-eager form in the language: the arm not selected is never
-- evaluated, so an error inside it never surfaces.
evalExpr ctx env (Branch condExpr thenExpr elseExpr) = do
cond <- evalExpr ctx env condExpr >>= liftEither . requireBool "a branch condition"
evalExpr ctx env (if cond then thenExpr else elseExpr)
evalExpr ctx env (Map collExpr fnExpr) = do
items <- evalCollection ctx env "map" collExpr
fnVal <- evalExpr ctx env fnExpr
VArray <$> traverse (\item -> apply ctx "map" fnVal [item]) items
evalExpr ctx env (Filter collExpr fnExpr) = do
items <- evalCollection ctx env "filter" collExpr
fnVal <- evalExpr ctx env fnExpr
kept <- traverse (\item -> (,) item <$> (apply ctx "filter" fnVal [item] >>= liftEither . requireBool "a filter predicate")) items
pure (VArray [item | (item, True) <- kept])
evalExpr ctx env (Scan collExpr initExpr fnExpr) = do
items <- evalCollection ctx env "scan" collExpr
acc0 <- evalExpr ctx env initExpr
fnVal <- evalExpr ctx env fnExpr
VArray <$> scanSteps ctx fnVal acc0 items
evalExpr ctx env (Fold collExpr initExpr fnExpr) = do
items <- evalCollection ctx env "fold" collExpr
acc0 <- evalExpr ctx env initExpr
fnVal <- evalExpr ctx env fnExpr
foldSteps ctx fnVal acc0 items
-- | 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
liftEither (concatValues l r)
-- | Wiring up an import evaluates its parameters and stops there. The library
-- itself runs later, when a field is read off the result, so parameters can
-- keep arriving in between.
--
-- @ctx(path)@ is substituted here, from the /importing/ program's own context
-- -- exactly what @$ctx.path@ would read, including the same 'PathNotFound'
-- when it is absent, which is why it evaluates as that very expression. It is
-- a distinct AST node purely so "Tramaj.Analysis" can read every hole off the
-- source without evaluating anything; the evaluator gains nothing from the
-- distinction and deliberately makes no other use of it.
-- | A @%@-marked entry (v4-types \S2) supplies a type, not a value, so it
-- never reaches the library's own @$ctx@ -- 'resolveParam' drops it, the
-- same way 'pParams' never has a slot for it, rather than passing some inert
-- placeholder through: the two channels sharing one params record share no
-- runtime representation at all, one being erased entirely before
-- evaluation (\S7).
evalExpr ctx env (Import name params) = do
supplied <- catMaybes <$> traverse resolveParam params
pure (VImport (Pending name (Map.fromList supplied) []))
where
resolveParam (k, PExpr e) = Just . (,) k <$> evalExpr ctx env e
resolveParam (k, PFromContext path) = Just . (,) k <$> evalExpr ctx env (Path "ctx" path)
resolveParam (_, PType _) = pure Nothing
evalExpr ctx env (AdaptActions targetExpr adaptation fnExpr) = do
target <- evalExpr ctx env targetExpr
fnVal <- traverse (evalExpr ctx env) fnExpr
adaptValue ctx adaptation fnVal target
-- | @constraint(name, args...)@ (v3-symbols \S2.1). Each argument must be
-- something that can cross a JSON boundary -- the same rule 'toJson' already
-- enforces everywhere else -- checked here and not deferred, since a
-- constraint carrying a closure would otherwise sit unnoticed until whatever
-- @!@ eventually reaches it, or never surface at all if none does.
evalExpr ctx env (Constrain name argExprs) = do
argVals <- traverse (evalExpr ctx env) argExprs
liftEither (traverse_ toJson argVals)
pure (VConstraint name argVals)
-- | @!expr@ (\S2.2): evaluates the constraint expression, collects from its
-- value by the coercion table 'collectConstraints' encodes, records what it
-- collected, then continues into the body -- the same "earlier bindings
-- only" shape 'Let' already has, since both nest into one chain.
evalExpr ctx env (Emit constraintExpr body) = do
cv <- evalExpr ctx env constraintExpr
collected <- liftEither (collectConstraints cv)
tellConstraints collected
evalExpr ctx env body
evalExpr ctx env e@(Alloc _ _) = evalBindable ctx env Nothing e
evalExpr ctx env e@(Demand _) = evalBindable ctx env Nothing e
-- | @type Name = TypeExpr@ (v4-types \S1.1, roadmap Phase 8): means nothing
-- to evaluation -- resolution is a static pass (v4-types \S9) -- so this
-- simply continues into the body.
evalExpr ctx env (TypeDecl _ _ body) = evalExpr ctx env body
-- | Every entry point below ('evalProgramWithEmissions', 'runLibrary') runs
-- "Tramaj.Types"\'s erasure pass before ever calling 'evalExpr', which
-- rewrites every 'TypeAnnotate' into the 'Let'\/'Emit' pair v4-types \S7
-- specifies -- so this case is not the normal path. It is kept total anyway,
-- exactly as 'TypeDecl'\'s case is total on purpose: matching what erasure
-- would have produced, minus the emission, keeps 'evalExpr' correct even if
-- a caller somehow reaches it pre-erasure, rather than leaving a partial
-- match for that case to crash on.
evalExpr ctx env (TypeAnnotate name _ valueExpr body) = evalExpr ctx env (Let name valueExpr body)
-- | @!type-constraint(...)@ (v4-types \S5, roadmap Phase 12): resolved by
-- the analyser, never evaluated -- \S5.1 is explicit that the evaluator's
-- statement fold skips this, exactly as it skips 'TypeDecl'.
evalExpr ctx env (TypeEmit _ _ body) = evalExpr ctx env body
-- | 'Alloc' and 'Demand' are the two forms whose symbol-table entry records
-- the name they were bound to, or 'Nothing' when used inline (v3-symbols
-- \S5.2's @"binding"@ field) -- everything else evaluates through plain
-- 'evalExpr', unaffected by whether it happens to sit on a 'Let'\'s
-- right-hand side.
evalBindable :: EvalCtx -> Env -> Maybe Text -> Expr -> Eval Value'
evalBindable ctx env binding (Alloc site keyExpr) = evalAlloc ctx env binding site keyExpr
evalBindable ctx env binding (Demand path) = evalDemand ctx env binding path
evalBindable ctx env _ other = evalExpr ctx env other
-- | @?(key)@ (\S1.2, \S4): the key is evaluated first, in both modes alike --
-- so an error inside it surfaces the same way regardless of mode -- and
-- only /minting/ depends on the mode (\S5.1): concrete mode has no way to
-- represent the result, symbolic mode allocates and records the entry.
evalAlloc :: EvalCtx -> Env -> Maybe Text -> Int -> Expr -> Eval Value'
evalAlloc ctx env binding site keyExpr = do
keyVal <- evalExpr ctx env keyExpr
keyJson <- liftEither (requireConcrete "?(...)" keyVal)
case ecMode ctx of
Concrete -> evalError SymbolsUnavailable
Symbolic -> do
let sid = "#" <> tshow site <> ":" <> canon keyJson
tellSymbol (SymbolEntry sid (OAlloc site keyJson) binding)
pure (VSymbol sid [])
-- | @?ctx.a.b@ (\S1.3): reads exactly as @$ctx.a.b@ would when the path is
-- supplied, in either mode -- 'tryEval' only ever looks past a
-- 'PathNotFound' it raises. Unsupplied, it allocates at the root (mode
-- permitting) and is an ordinary unsupplied read anywhere else, which
-- 'mapEvalError' in 'runLibrary' already tags with 'InLibrary'.
evalDemand :: EvalCtx -> Env -> Maybe Text -> [Text] -> Eval Value'
evalDemand ctx env binding path = do
attempt <- tryEval (evalExpr ctx env (Path "ctx" path))
case attempt of
Right v -> pure v
Left (PathNotFound _) | ecIsRoot ctx -> case ecMode ctx of
Concrete -> evalError SymbolsUnavailable
Symbolic -> do
let sid = "#ctx" <> mconcat (map ("." <>) path)
tellSymbol (SymbolEntry sid (ODemand path) binding)
pure (VSymbol sid [])
Left e -> evalError e
-- | Runs an 'Eval' computation and reports whether it failed, without
-- discarding whatever it had already accumulated on success. Used only to
-- look past a 'PathNotFound' that might mean "allocate instead" -- every
-- other error still propagates once inspected.
tryEval :: Eval a -> Eval (Either EvalError a)
tryEval (MkEval e) = MkEval $ case e of
Left err -> Right (Left err, mempty)
Right (a, w) -> Right (Right a, w)
-- | The coercion table a @!@ collects by (v3-symbols \S2.2): a constraint
-- contributes itself; an array contributes each element, recursively, which
-- is why @!map(...)@ and @!$cs@ (a binding holding an array built earlier)
-- both read naturally; anything else is a 'TypeMismatch'.
collectConstraints :: Value' -> Either EvalError [Value']
collectConstraints v@(VConstraint _ _) = Right [v]
collectConstraints (VArray xs) = concat <$> traverse collectConstraints xs
collectConstraints other = Left (TypeMismatch ("! expects a constraint or an array of them, got " <> describeValue other))
-- | Only for error messages: what the source called, as written.
describeCallee :: Expr -> Text
describeCallee (Path root fields) = T.intercalate "." (root : fields)
describeCallee _ = "a call"
-- Documents -------------------------------------------------------------------
evalAttribute :: EvalCtx -> Env -> Attribute -> Eval NodeAttribute
evalAttribute ctx env (Attr name e) = NAttr name <$> (evalExpr ctx env e >>= liftEither . toJson)
evalAttribute ctx env (ActionAttr event key payloadExpr) =
NAction event key <$> (evalExpr ctx env payloadExpr >>= liftEither . toJson)
evalChildren :: EvalCtx -> Env -> [Expr] -> Eval [Node]
evalChildren ctx env children =
concat <$> traverse (\e -> evalExpr ctx env e >>= liftEither . childNodes) children
-- | How a value becomes children. A node is itself one child; an array
-- contributes each of its elements, which is how @map(...)@ produces repeated
-- siblings without a document-specific map form; anything else becomes a text
-- node carrying that value unconverted, so a number child stays a number.
--
-- A closure, an unfinished import or a constraint has no rendering, and
-- 'toJson' says so -- a 'VConstraint' reaching here is exactly \S2.1's rule
-- that a constraint MUST NOT cross a JSON boundary, including as a child.
childNodes :: Value' -> Either EvalError [Node]
childNodes (VNode' n) = Right [n]
childNodes (VArray xs) = concat <$> traverse childNodes xs
childNodes v = (\j -> [NText j noAnnotations]) <$> toJson v
-- Application ------------------------------------------------------------------
apply :: EvalCtx -> Text -> Value' -> [Value'] -> Eval Value'
apply ctx _ (VClosure params body closureEnv) args
| length params /= length args =
evalError (TypeMismatch ("closure expects " <> tshow (length params) <> " argument(s), got " <> tshow (length args)))
| otherwise =
evalExpr ctx (foldl' (\e (p, v) -> Map.insert p v e) closureEnv (zip params args)) body
apply _ _ (VBuiltin name) args = liftEither (evalBuiltin name args)
-- | Saturating an import: the argument is more parameters, merged over what it
-- already has. Right-biased, like @\<\>@ on objects, so a later call overrides
-- an earlier value for the same name -- which is what makes one wired-up
-- import reusable across a @map@, each iteration supplying its own.
apply _ who (VImport pending) args = case args of
[VObject more] -> pure (VImport pending {pParams = Map.union more (pParams pending)})
[other] ->
evalError
( TypeMismatch
(who <> ": the import of " <> tshow (pName pending) <> " takes an object of parameters, got " <> describeValue other)
)
_ -> evalError (TypeMismatch (who <> ": the import of " <> tshow (pName pending) <> " expects exactly 1 argument, the parameters to add"))
apply _ who v _ = evalError (TypeMismatch (who <> " is not callable: " <> describeValue v))
-- | @scan@'s output is @[init, f(init, x1), f(f(init, x1), x2), ...]@ --
-- @scanl@, not @scanl1@.
scanSteps :: EvalCtx -> Value' -> Value' -> [Value'] -> Eval [Value']
scanSteps _ _ acc [] = pure [acc]
scanSteps ctx fnVal acc (item : rest) = do
next <- apply ctx "scan" fnVal [acc, item]
(acc :) <$> scanSteps ctx fnVal next rest
-- | The same steps as 'scanSteps', keeping only the final accumulator.
foldSteps :: EvalCtx -> Value' -> Value' -> [Value'] -> Eval Value'
foldSteps _ _ acc [] = pure acc
foldSteps ctx fnVal acc (item : rest) = do
next <- apply ctx "fold" fnVal [acc, item]
foldSteps ctx fnVal next rest
-- | 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 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 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))
concatValues l r = Left (ConcatMismatch (describeValue l) (describeValue r))
-- Imports --------------------------------------------------------------------------
-- | Runs the library behind an import, against the parameters it has
-- accumulated, and applies whatever adaptations were queued on it.
--
-- This is the only place a library runs, and 'walkFields' is the only caller:
-- an import runs when a field is read off it, never where it is written.
-- Nothing checks first whether the parameters are enough -- there is no list
-- of what "enough" would be. A library that reads a @$ctx@ path nobody
-- supplied fails with its own 'PathNotFound', tagged by 'runLibrary' with the
-- library's name.
forceImport :: EvalCtx -> Pending -> Eval Value'
forceImport ctx pending = do
result <- runLibrary ctx (pName pending) (VObject (pParams pending))
applyQueued ctx (pQueued pending) result
-- | Evaluates a library against its own fresh @$ctx@ -- the parameters it was
-- given -- and exposes @{rendered, vals}@. @inProgress@ carries the libraries
-- already being evaluated on this chain, so re-entering one is reported as a
-- cycle instead of running forever.
--
-- Bindings are replayed by hand, via 'foldlEval' over 'bindStep', rather than
-- letting a single 'evalExpr' over the whole chain produce @rendered@:
-- that is what exposes each binding's own value for @.vals@ without a
-- separate environment-inspection mechanism. Any @!@ interleaved among the
-- bindings (v3-symbols \S2.3 -- "a library's emissions are collected ... when
-- a field is read off its import") is replayed the same way, in the same
-- pass, so its constraints are collected exactly once, at its position in
-- the chain -- this is the fix for the 'unlets' trap: the old version simply
-- stopped at the first non-'Let', which silently dropped both the bindings
-- after a @!@ and the @!@'s own constraint.
runLibrary :: EvalCtx -> Text -> Value' -> Eval Value'
runLibrary ctx name ctxVal
| Set.member name (ecInProgress ctx) = evalError (ImportCycle name)
| otherwise = do
rawProg <- liftEither (maybe (Left (UnknownLibrary name)) Right (Map.lookup name (ecLibs ctx)))
liftEither (if Set.null (symbolSites rawProg) then Right () else Left (AllocationInLibrary name))
prog <- liftEither (first TypeErr (eraseTypes (ecLibs ctx) rawProg))
mapEvalError (InLibrary name) $ do
let ctx' = enterLibrary name ctx
(statements, root) = unlets (programRoot prog)
libEnv <- foldlEval (bindStep ctx') (initialEnv (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)))]))
where
bindStep ctx' env (SLet n e) = do
v <- evalExpr ctx' env e
pure (Map.insert n v env)
bindStep ctx' env (SEmit e) = do
cv <- evalExpr ctx' env e
collected <- liftEither (collectConstraints cv)
tellConstraints collected
pure env
-- | A type declaration means nothing to the evaluator (v4-types, roadmap
-- Phase 8) -- it exists for static resolution alone, so replaying it here
-- is a no-op on the environment.
bindStep _ env (STypeDecl _ _) = pure env
-- | See 'evalExpr'\'s 'TypeAnnotate' case: erasure has already turned
-- this into a 'SLet' plus 'SEmit' by the time a library's own chain gets
-- here, so this branch, like that one, only guards totality.
bindStep ctx' env (SAnnotate n _ e) = do
v <- evalExpr ctx' env e
pure (Map.insert n v env)
-- | See 'evalExpr'\'s 'TypeEmit' case: never evaluated.
bindStep _ env (STypeEmit _ _) = pure env
-- Action adaptation -------------------------------------------------------------------
-- | Applies an adaptation everywhere it can reach: through a node's whole
-- tree, through every value of an import result (not just @rendered@), and
-- through arrays. An import that has not run has no actions yet, so the
-- adaptation is queued and runs on its result. Anything else has no actions
-- and passes through untouched.
adaptValue :: EvalCtx -> ActionAdaptation -> Maybe Value' -> Value' -> Eval Value'
adaptValue ctx adaptation fnVal = go
where
go (VNode' n) = VNode' <$> mapActions (adaptAction ctx adaptation fnVal) n
go (VEnv e) = VEnv <$> traverse go e
go (VArray xs) = VArray <$> traverse go xs
go (VObject o) = VObject <$> traverse go o
go (VImport pending) = pure (VImport pending {pQueued = pQueued pending <> [(adaptation, fnVal)]})
go v = pure v
applyQueued :: EvalCtx -> [(ActionAdaptation, Maybe Value')] -> Value' -> Eval Value'
applyQueued ctx queued v0 =
foldlEval (\v (adaptation, fnVal) -> adaptValue ctx adaptation fnVal v) v0 queued
-- | One action, adapted. The key is rewritten first, unconditionally, by the
-- static adaptation; the optional closure then sees the already-adapted action
-- and may change only its event type and payload. A @key@ in the closure's
-- result is ignored -- letting it win would put the action vocabulary back
-- beyond static reach, which is the whole point of restricting adaptation.
adaptAction :: EvalCtx -> ActionAdaptation -> Maybe Value' -> Text -> Text -> 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
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 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
key' = adaptKey adaptation key
actionAsValue =
VObject
(Map.fromList [("eventType", VString event), ("key", VString key'), ("payload", fromJson payload)])
-- Paths and fields -----------------------------------------------------------------------
-- | Walks named segments into a value. @context@ is the full path as written,
-- for error messages only.
walkFields :: EvalCtx -> [Text] -> Value' -> [Text] -> Eval Value'
walkFields _ _ v [] = pure v
walkFields ctx context v fields@(field : rest) = case v of
VObject o -> case Map.lookup field o of
Nothing -> evalError (PathNotFound context)
Just v' -> walkFields ctx context v' rest
VEnv e -> case Map.lookup field e of
Nothing -> evalError (PathNotFound context)
Just v' -> walkFields ctx context v' rest
-- Reading a field off an import is what runs it -- @.rendered@ and @.vals@
-- are fields of the result, so the same segment is then walked into that
-- result rather than consumed here.
VImport pending -> do
result <- forceImport ctx pending
walkFields ctx context result fields
-- Projection (v3-symbols \S1.6): reads nothing, and is never rejected --
-- whether the thing a symbol stands for has this field is a question for
-- whoever owns its meaning, not the language. Consumes every remaining
-- segment at once, since a projection just extends the path.
VSymbol sid path -> pure (VSymbol sid (path <> fields))
-- 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
("cannot read field " <> tshow field <> " of " <> describeValue other <> " in path " <> tshow (T.intercalate "." context))
)
-- Conversion ------------------------------------------------------------------------------
-- | Down to JSON, at the boundaries where only JSON is meaningful: an
-- attribute value, an action payload, an element's value slot, an expression
-- program's result.
--
-- The values that cannot cross say why. A node is deliberately included:
-- documents nest as children, not as attribute values, and silently
-- serializing one here would hide a mistake rather than report it.
toJson :: Value' -> Either EvalError 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
-- child (v3-symbols \S1.5), so this always succeeds -- it is 'requireConcrete'
-- that refuses one, for the handful of forms that need to. \S5.3's tagged
-- shape: both fields required, matching what the decoder in
-- 'checkedFromJson' accepts back.
toJson (VSymbol sid path) =
Right (object [("$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")
toJson (VImport pending) =
Left
( TypeMismatch
( "expected a value, got the import of "
<> tshow (pName pending)
<> " -- read .rendered or .vals from it to run it first"
)
)
-- | 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. 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
decode (JArray xs) = VArray <$> traverse decode xs
decode (JObject obj)
| Map.member "$type" obj =
Left (TypeMismatch "the context carries the reserved key \"$type\", which only a typed envelope may use")
| Just symVal <- Map.lookup "$sym" obj =
case optMode options of
Concrete -> Left (TypeMismatch "the context carries the reserved key \"$sym\", which only a symbolic envelope may use")
Symbolic -> case (symVal, Map.toList (Map.delete "$sym" obj)) of
(JString sid, [("path", JArray pathArr)]) -> do
path <- traverse expectString pathArr
Right (VSymbol sid path)
_ -> Left (TypeMismatch "a \"$sym\" object must be exactly {\"$sym\": <id>, \"path\": [<segment>, ...]}")
| Just opVal <- Map.lookup "$term" obj =
case optMode options of
Concrete -> Left (TypeMismatch "the context carries the reserved key \"$term\", which only a symbolic envelope may use")
Symbolic -> case (opVal, Map.toList (Map.delete "$term" obj)) of
(JString op, [("arguments", JArray args)]) -> traverse decode args >>= seededTerm op
_ -> Left (TypeMismatch "a \"$term\" object must be exactly {\"$term\": <op>, \"arguments\": [<argument>, ...]}")
| otherwise = VObject <$> traverse decode obj
decode scalar = Right (fromJson scalar)
-- A well-formed term is one a call could have built (\S5.3), so this is
-- the call's own check, 'arithmeticOperands', on arguments already
-- decoded, which holds a nested term to the same rule. Two things a call
-- accepts are refused first: an array, since a term holds its operands
-- already flattened, and operands that are all numbers, since the call
-- would have computed. Without the arithmetic profile no @op@ is known,
-- so every term is refused.
seededTerm op args
| not (optArithmetic options) = Left (TypeMismatch ("the context carries a term (" <> tshow op <> "), which needs the arithmetic profile"))
| op `notElem` arithmeticNames = Left (TypeMismatch ("a term names an unknown operation: " <> tshow op))
| any isArray args = Left (TypeMismatch ("a term (" <> tshow op <> ") holds its operands flattened, not in an array"))
| otherwise = do
operands <- arithmeticOperands op args
if any isSymbolic operands
then Right (VTerm op operands)
else Left (TypeMismatch ("a term (" <> tshow op <> ") must hold a symbol or a term among its arguments"))
isArray (VArray _) = True
isArray _ = False
expectString (JString s) = Right s
expectString _ = Left (TypeMismatch "a symbol reference's \"path\" must be an array of strings")
describeValue :: Value' -> Text
describeValue VNull = "null"
describeValue (VBool _) = "a boolean"
describeValue (VInt _) = "an integer"
describeValue (VFloat _) = "a float"
describeValue (VString _) = "a string"
describeValue (VArray _) = "an array"
describeValue (VObject _) = "an object"
describeValue (VNode' _) = "a document node"
describeValue (VClosure _ _ _) = "a function"
describeValue (VBuiltin name) = "the builtin " <> tshow name
describeValue (VEnv _) = "an import result"
describeValue (VImport pending) = "the not-yet-run import of " <> tshow (pName pending)
describeValue (VConstraint name _) = "a constraint (" <> tshow name <> ")"
describeValue (VSymbol _ _) = "a symbol"
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 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 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 Json
requireConcrete who v
| containsSymbol v = Left (NotConcrete who)
| otherwise = toJson v
-- | v3-symbols \S1.4: compact JSON with keys sorted, agreeing with @str@ on
-- arrays and objects and differing at the top level for strings, where
-- @str@ renders raw and this quotes -- the difference that makes it
-- injective. This is exactly '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
-- Builtins ------------------------------------------------------------------------------------
-- | A fixed vocabulary, grown only on real demand. @branch@ is absent
-- deliberately: it has to leave an arm unevaluated, which no builtin can do,
-- so it is a core constructor instead.
evalBuiltin :: Text -> [Value'] -> Either EvalError Value'
evalBuiltin name args = case name of
"cardinality" -> cardinality
"count" -> cardinality
"str" -> arity1 (fmap (VString . displayString) . requireConcrete name)
"not" -> arity1 (fmap (VBool . not) . asBool)
"and" -> variadicBool (&&) True
"or" -> variadicBool (||) False
-- 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 (>=) (>=)
"has" -> binary hasImpl
"lookup" -> ternary lookupImpl
"format-number" -> ternary formatNumberImpl
"concat" -> concatImpl
"append" -> binary appendImpl
_
| name `elem` arithmeticNames -> arithmetic name args
| otherwise -> Left (UnboundName name)
where
arity1 :: (Value' -> Either EvalError a) -> Either EvalError a
arity1 f = case args of
[a] -> f a
_ -> Left (TypeMismatch (name <> " expects exactly 1 argument, got " <> tshow (length args)))
binary :: (Value' -> Value' -> Either EvalError Value') -> Either EvalError Value'
binary f = case args of
[a, b] -> f a b
_ -> Left (TypeMismatch (name <> " expects exactly 2 arguments, got " <> tshow (length args)))
ternary :: (Value' -> Value' -> Value' -> Either EvalError Value') -> Either EvalError Value'
ternary f = case args of
[a, b, c] -> f a b c
_ -> Left (TypeMismatch (name <> " expects exactly 3 arguments, got " <> tshow (length args)))
cardinality :: Either EvalError Value'
cardinality = arity1 $ \case
VArray xs -> Right (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))
-- | 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']
asArray (VArray xs) = Right xs
asArray other = Left (TypeMismatch (name <> " expects an array argument, got " <> describeValue other))
-- | @and@\/@or@ fold over however many arguments they are given, zero
-- included (vacuously), rather than fixing an arity.
variadicBool :: (Bool -> Bool -> Bool) -> Bool -> Either EvalError Value'
variadicBool op identityVal = VBool . foldl' op identityVal <$> traverse asBool args
-- | 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
-- -- except a symbolic container, which is 'NotConcrete' rather than a
-- lie (v3-symbols \S1.5): the tolerant @false@ would claim to know
-- something about a container the language cannot see into.
hasImpl :: Value' -> Value' -> Either EvalError Value'
hasImpl (VSymbol _ _) _ = Left (NotConcrete name)
hasImpl (VTerm _ _) _ = Left (NotConcrete name)
hasImpl container key = Right . VBool $ case (container, key) of
(VObject o, VString k) -> Map.member k o
(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
-- static path segment. The third argument is the mandatory fallback. A
-- symbolic container is 'NotConcrete' rather than falling back, which
-- would silently discard the symbol (\S1.5).
lookupImpl :: Value' -> Value' -> Value' -> Either EvalError Value'
lookupImpl (VSymbol _ _) _ _ = Left (NotConcrete name)
lookupImpl (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, 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 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.
concatImpl :: Either EvalError Value'
concatImpl = VArray . concat <$> traverse asArray args
-- | @append(arr, item)@ adds one element at the end. An array item is
-- appended as a single element, not spliced -- @concat@ splices.
appendImpl :: Value' -> Value' -> Either EvalError Value'
appendImpl arr item = (\xs -> VArray (xs <> [item])) <$> asArray arr
-- Arithmetic (reference.md \S11) ----------------------------------------------------------------
-- | 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'.
--
-- * @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
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)))
variadic = name `elem` (["sum", "product"] :: [Text])
arity :: Int
arity = if name `elem` (["quotient", "floor-quotient", "modulo"] :: [Text]) then 2 else 1
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.
--
-- 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.
--
-- 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)))
-- 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
-- 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