tramaj-hs-0.3.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 (..)
  , LibraryTable
  , evalProgram
  , runProgram
  , evalExprWith
  , builtinNames
  ) where

import Data.Aeson (Value (..), encode)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Bifunctor (first)
import Data.Char (intToDigit)
import Data.Foldable (traverse_)
#if __GLASGOW_HASKELL__ >= 910
import Data.List (sortOn)
#else
import Data.List (foldl', sortOn)
#endif
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.Scientific (Scientific, fromFloatDigits, toRealFloat)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Vector as V
import Numeric (floatToDigits)
import Tramaj.Analysis (symbolSites)
import Tramaj.Ast
import Tramaj.Node
import Tramaj.Types (ResolvedConstraintArg (..), ResolvedType (..), TypeError, canonicalId, deepTypeConstraints, eraseTypes, programTypeRoots, typeClosure)

data EvalError
  = UnboundName Text
  | PathNotFound [Text]
  | TypeMismatch Text
  | UnknownLibrary Text
  | ImportCycle Text
  | -- | @a \<\> b@ where the two sides are not the same concatenable type.
    ConcatMismatch Text Text
  | -- | Whatever went wrong inside an imported library, tagged with which
    -- library it was. Nests, so a failure three imports deep reads as the
    -- chain that reached it. This matters most for the parameter a library
    -- needs and the import never supplied: that surfaces as this library's
    -- own @PathNotFound ["ctx", ...]@, and without the tag there would be
    -- nothing on it to say whose context was short.
    InLibrary Text EvalError
  | -- | A symbol would have to be minted in concrete mode: an allocation
    -- (@?(k)@, v3-symbols \S4) or an unsupplied @?ctx.path@ demand at the root
    -- (\S1.3). Concrete mode has no way to represent either. Symbolic mode
    -- never raises it: that is the one mode where a symbol is representable.
    SymbolsUnavailable
  | -- | A symbolic value where the language requires a concrete one (\S1.5's
    -- table, and a symbol used as an allocation key).
    NotConcrete Text
  | -- | A program containing @?(k)@ is loaded as a library (\S1.4): only the
    -- root may allocate, because the root runs exactly once and a library
    -- does not. Lexical, not data-flow -- raised because the library's own
    -- source contains an allocation site, whether or not evaluation would
    -- ever reach it.
    AllocationInLibrary Text
  | -- | A static v4-types failure (v4-types \S10), surfaced from either the
    -- erasure pass every entry point below runs before evaluating anything
    -- (\S7, roadmap Phase 11) or from building the symbolic envelope's
    -- @\"types\"@\/@\"type-constraints\"@ lists (\S8, Phase 13). Not a new
    -- evaluation failure mode -- nothing here is raised /during/ evaluation
    -- -- but 'Tramaj.Types.TypeError' still needs a home in the one error
    -- type every entry point already returns.
    TypeErr TypeError
  deriving stock (Eq, Show)

-- | What a program produced. Which one it is follows from the value the root
-- actually evaluated to, not from how the root was written: a program whose
-- root is @$header@ yields a document if that binding holds one.
data Output
  = ONode Node
  | OValue Value
  deriving stock (Eq, Show)

-- | A host parameter, not a property of the program (v3-symbols \S5): what an
-- interpreter is willing to read back out, not anything the template itself
-- declares. 'Concrete' is @reference.md@ exactly -- Node JSON or a plain
-- value, byte for byte. 'Symbolic' wraps the same evaluation in the v3
-- envelope (\S5.2); until \S3\/\S4 land, that envelope's @"symbols"@ and
-- @"constraints"@ are always empty, because nothing yet produces either.
data Mode = Concrete | Symbolic
  deriving stock (Eq, Show)

-- | Host-supplied library store. Where a library came from -- a file, an
-- embedded string, a fetch -- is entirely the host's business; the evaluator
-- only ever sees an already-parsed 'Program'.
type LibraryTable = Map Text Program

-- | The language's value domain.
--
-- 'VArray'\/'VObject' hold 'Value'', not JSON, so a document node can travel
-- inside a structure like any other value. 'VEnv' is an import's
-- @{rendered, vals}@ result. 'VImport' is an import that has been wired up but
-- not run -- reading a field off it is what runs it.
--
-- There is no recursion: 'Let' inserts a binding only after evaluating its
-- right-hand side, so a closure cannot see its own name.
data Value'
  = VNull
  | VBool Bool
  | VNumber Scientific
  | VString Text
  | VArray [Value']
  | VObject (Map Text Value')
  | VNode' Node
  | VClosure [Text] Expr Env
  | VBuiltin Text
  | VEnv Env
  | VImport Pending
  | -- | @constraint(name, args...)@ (v3-symbols \S2.1): a value like any
    -- other, so it can be bound, passed around and collected into an array,
    -- right up until it tries to cross a JSON boundary ('toJson' refuses it)
    -- or is left unreached by any @!@.
    VConstraint Text [Value']
  | -- | A symbol (\S1.1): opaque data, identified by 'SymbolId' and a
    -- projection path extended one segment at a time by field access
    -- (\S1.6). An allocation (@?(k)@) starts with an empty path; so does a
    -- demand (@?ctx.path@) once minted -- its own path is baked into the id,
    -- not carried here.
    VSymbol SymbolId [Text]

type Env = Map Text Value'

-- | A symbol's identity (\S1.4): a string, identical in every conforming
-- implementation for the same program and key. Kept distinct from 'Text'
-- only so the two forms ('renderAllocId', 'renderDemandId') stay the only
-- places one is built.
type SymbolId = Text

-- | An entry in the symbol table (\S5.2). Only allocations appear there --
-- which includes an unsupplied demand minted at the root (\S1.3), since
-- that too is the root allocating -- and a symbol the host seeded (\S5.4)
-- is never listed, because the language has nothing to add about one it
-- did not mint.
data SymbolEntry = SymbolEntry
  { seId :: SymbolId
  , seOrigin :: SymbolOrigin
  , seBinding :: Maybe Text
  }
  deriving stock (Eq, Show)

-- | Where a symbol table entry came from: an @?(k)@ at a given site, with
-- the key it was allocated with already reduced to JSON; or an unsupplied
-- @?ctx.path@ demand, minted at the root.
data SymbolOrigin
  = OAlloc Int Value
  | ODemand [Text]
  deriving stock (Eq, Show)

-- | An import that has been named and wired up, and has not run.
--
-- @pParams@ is everything supplied so far, however it arrived: an expression,
-- a @ctx(path)@ read out of the importing program's own context at the wiring
-- site, or a later call adding more. Nothing here records what is still
-- /missing/, because nothing here knows: the library decides that when it runs
-- and reads its @$ctx@. That is the whole point of the design -- an omitted
-- parameter is what defers an import, so partiality needs no declaration and
-- no bookkeeping.
--
-- @pQueued@ holds adaptations applied before the import ran; they run on the
-- result, once there are actions for them to reach.
data Pending = Pending
  { pName :: Text
  , pParams :: Map Text Value'
  , pQueued :: [(ActionAdaptation, Maybe Value')]
  }

-- | Everything evaluation needs to know about that is not the local
-- environment: the library table, the set of libraries already being
-- evaluated on this chain (cycle detection), the mode (v3-symbols \S5), and
-- whether this is the root program or somewhere inside a library (\S1.3,
-- \S1.4) -- bundled so that adding one more such fact, as \S1.4's did,
-- touches this record instead of every function's argument list.
data EvalCtx = EvalCtx
  { ecLibs :: LibraryTable
  , ecInProgress :: Set Text
  , ecMode :: Mode
  , ecIsRoot :: Bool
  }

-- | Enters a library: adds it to the in-progress set (so re-entering it is a
-- cycle, not a loop) and clears 'ecIsRoot' -- a library never allocates or
-- mints (\S1.3, \S1.4), no matter how deep the chain that reached it.
enterLibrary :: Text -> EvalCtx -> EvalCtx
enterLibrary name ctx = ctx {ecInProgress = Set.insert name (ecInProgress ctx), ecIsRoot = False}

-- | What evaluation accumulates alongside its result (v3-symbols \S4):
-- emitted constraints and allocated symbol-table entries, each in
-- evaluation order and each deduplicated only once, globally, at the top
-- (\S4 -- "first position kept") rather than on every append.
data Emissions = Emissions
  { emConstraints :: [Value']
  , emSymbols :: [SymbolEntry]
  }

instance Semigroup Emissions where
  Emissions c1 s1 <> Emissions c2 s2 = Emissions (c1 <> c2) (s1 <> s2)

instance Monoid Emissions where
  mempty = Emissions [] []

-- The evaluation monad -------------------------------------------------------

-- | Evaluation threads two things besides the value it produces: it can fail
-- with an 'EvalError', and it accumulates 'Emissions' monoidally -- appended
-- in evaluation order, never mutated in place, so 'Branch' evaluating only
-- its selected arm gives exactly the right emission set for free, with no
-- separate mechanism.
newtype Eval a = MkEval {runEval :: Either EvalError (a, Emissions)}

instance Functor Eval where
  fmap f (MkEval e) = MkEval (fmap (\(a, w) -> (f a, w)) e)

instance Applicative Eval where
  pure a = MkEval (Right (a, mempty))
  MkEval mf <*> MkEval ma = MkEval $ do
    (f, w1) <- mf
    (a, w2) <- ma
    pure (f a, w1 <> w2)

instance Monad Eval where
  MkEval ma >>= f = MkEval $ do
    (a, w1) <- ma
    (b, w2) <- runEval (f a)
    pure (b, w1 <> w2)

evalError :: EvalError -> Eval a
evalError e = MkEval (Left e)

-- | Brings a pure, non-emitting computation into 'Eval' -- every helper that
-- only inspects already-evaluated 'Value''s (no 'Expr' to evaluate, so
-- nothing it could emit) stays plain 'Either' and is lifted at the call site.
liftEither :: Either EvalError a -> Eval a
liftEither = MkEval . fmap (,mempty)

-- | Records constraints reached by a @!@ (v3-symbols \S2.2), in the order
-- given.
tellConstraints :: [Value'] -> Eval ()
tellConstraints vs = MkEval (Right ((), mempty {emConstraints = vs}))

-- | Records one symbol-table entry, minted by an allocation or an
-- unsupplied demand at the root (\S1.3, \S5.2).
tellSymbol :: SymbolEntry -> Eval ()
tellSymbol entry = MkEval (Right ((), mempty {emSymbols = [entry]}))

-- | Maps over the error only, leaving any emissions already accumulated
-- alone -- 'InLibrary'\'s tag, applied the same way 'Data.Bifunctor.first'
-- tags a plain 'Either'.
mapEvalError :: (EvalError -> EvalError) -> Eval a -> Eval a
mapEvalError f (MkEval e) = MkEval (first f e)

foldlEval :: (b -> a -> Eval b) -> b -> [a] -> Eval b
foldlEval f = go
  where
    go acc [] = pure acc
    go acc (x : xs) = f acc x >>= \acc' -> go acc' xs

-- Entry points ---------------------------------------------------------------

-- | Evaluation now depends on the mode (v3-symbols \S5): an allocation or an
-- unsupplied root demand mints a symbol in symbolic mode and raises
-- 'SymbolsUnavailable' in concrete mode. There is no mode-independent
-- evaluation any more, so every entry point takes one.
evalProgram :: Mode -> LibraryTable -> Value -> Program -> Either EvalError Output
evalProgram mode libs input prog = fst <$> evalProgramWithEmissions mode libs input prog

-- | As 'evalProgram', but also returns the deduplicated 'Emissions'
-- (v3-symbols \S4) -- empty for any program that emits or allocates nothing,
-- and always empty in what concrete mode goes on to serialize, since
-- concrete mode discards them (\S5.1) and cannot produce a symbol at all.
evalProgramWithEmissions :: Mode -> LibraryTable -> Value -> Program -> Either EvalError (Output, Emissions)
evalProgramWithEmissions mode libs input prog = do
  erased <- first TypeErr (eraseTypes libs prog)
  (v, emitted) <- runEval $ do
    ctx <- liftEither (checkedFromJson mode input)
    let evalCtx = EvalCtx {ecLibs = libs, ecInProgress = Set.empty, ecMode = mode, ecIsRoot = True}
    evalExpr evalCtx (initialEnv ctx) (programRoot erased)
  output <- case v of
    VNode' n -> Right (ONode n)
    other -> OValue <$> toJson other
  pure (output, dedupe emitted)

-- | Two constraints with the same name and equal arguments are one
-- constraint, and two symbol-table entries with the same id are one entry --
-- each kept at the position of the first (v3-symbols \S4). Constraint
-- equality is on the already-evaluated 'Value'', which is why this must run
-- after evaluation rather than being folded into 'tellConstraints' -- two
-- constraints built from different expressions can still evaluate to the
-- same fact.
dedupe :: Emissions -> Emissions
dedupe (Emissions cs ss) = Emissions (dedupeBy constraintEq cs) (dedupeBy (\a b -> seId a == seId b) ss)
  where
    dedupeBy eq = go []
      where
        go _ [] = []
        go seen (x : xs)
          | any (eq x) seen = go seen xs
          | otherwise = x : go (x : seen) xs

-- | Structural equality restricted to what a constraint's identity is made
-- of: its name and its arguments, each compared as the JSON they will
-- render as. Two constraints are the same fact regardless of which
-- expressions produced them.
constraintEq :: Value' -> Value' -> Bool
constraintEq (VConstraint n1 as1) (VConstraint n2 as2) =
  n1 == n2 && length as1 == length as2 && and (zipWith argEq as1 as2)
  where
    argEq a b = case (toJson a, toJson b) of
      (Right ja, Right jb) -> ja == jb
      _ -> False
constraintEq _ _ = False

-- | The mode-aware entry point: what a host actually serializes. Concrete
-- mode is 'evalProgram' unchanged, projected down to plain JSON -- Node JSON
-- for a document, the value itself for an expression, with any emissions
-- discarded (v3-symbols \S5.1). Symbolic mode wraps the same 'Output' in the
-- v3 envelope (\S5.2), including the deduplicated symbol table and
-- constraint list.
runProgram :: Mode -> LibraryTable -> Value -> Program -> Either EvalError Value
runProgram mode libs input prog = do
  result <- evalProgramWithEmissions mode libs input prog
  typesInfo <- case mode of
    Concrete -> Right (Map.empty, [])
    Symbolic -> first TypeErr (buildTypesInfo libs prog)
  pure (renderOutput mode typesInfo result)

-- | The @\"types\"@ table's entries and the deduplicated @\"type-constraints\"@
-- list (v4-types \S8, roadmap Phase 13), computed from @prog@ /before/
-- erasure -- unlike evaluation, which never needs a 'TypeAnnotate' or
-- 'TypeEmit' once erasure has run, this is the one place they still matter:
-- the envelope is exactly where a host needs the definitions and constraints
-- those nodes named. Concrete mode never calls this ('runProgram' short-
-- circuits it), matching \S8's promise that a v3 consumer reading a v4
-- envelope sees nothing new.
buildTypesInfo :: LibraryTable -> Program -> Either TypeError (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])])
buildTypesInfo libs prog = do
  roots <- programTypeRoots libs prog
  closure <- typeClosure libs prog roots
  tcs <- deepTypeConstraints libs prog
  pure (closure, tcs)

renderOutput :: Mode -> (Map Text ResolvedType, [(Text, [ResolvedConstraintArg])]) -> (Output, Emissions) -> Value
renderOutput Concrete _ (output, _) = case output of
  ONode n -> nodeToJson n
  OValue v -> v
renderOutput Symbolic (typesTable, typeConstraintsList) (output, Emissions constraints symbols) =
  Object
    ( KeyMap.fromList
        [ ("format", String "tramaj/symbolic/1")
        , ("kind", String kind)
        , ("root", root)
        , ("symbols", Array (V.fromList (map symbolEntryToJson symbols)))
        , ("constraints", Array (V.fromList (map constraintToJson constraints)))
        , ("types", Array (V.fromList (map typeEntryToJson (Map.toList typesTable))))
        , ("type-constraints", Array (V.fromList (map typeConstraintToJson typeConstraintsList)))
        ]
    )
  where
    (kind, root) = case output of
      ONode n -> ("document", nodeToJson n)
      OValue v -> ("expression", v)

-- | One @\"types\"@ table entry (v4-types \S8): the id, and the definition
-- behind it, rendered by 'resolvedTypeToJson'.
typeEntryToJson :: (Text, ResolvedType) -> Value
typeEntryToJson (tid, rt) =
  Object (KeyMap.fromList [("id", String tid), ("definition", resolvedTypeToJson rt)])

-- | A 'ResolvedType'\'s @\"definition\"@ shape (v4-types \S8's example): a
-- tagged union whose @kind@ names which of the six algebra shapes it is. A
-- 'RRef' renders as a pointer only -- its own definition is a separate entry
-- in the table, not inlined here -- which is \S3's "stop at declaration
-- boundaries" clause, still honoured at the JSON boundary.
resolvedTypeToJson :: ResolvedType -> Value
resolvedTypeToJson (RPrim name) = Object (KeyMap.fromList [("kind", String "prim"), ("name", String name)])
resolvedTypeToJson (RArray t) = Object (KeyMap.fromList [("kind", String "array"), ("element", resolvedTypeToJson t)])
resolvedTypeToJson (RRecord fields) =
  Object (KeyMap.fromList [("kind", String "record"), ("fields", Array (V.fromList (map field fields)))])
  where
    field (name, t) = Object (KeyMap.fromList [("name", String name), ("type", resolvedTypeToJson t)])
resolvedTypeToJson (RUnion arms) =
  Object (KeyMap.fromList [("kind", String "union"), ("arms", Array (V.fromList (map arm arms)))])
  where
    arm (name, mt) =
      Object (KeyMap.fromList (("name", String name) : maybe [] (\t -> [("payload", resolvedTypeToJson t)]) mt))
resolvedTypeToJson r@(RRef _ _ _) = Object (KeyMap.fromList [("kind", String "ref"), ("id", String (canonicalId r))])
resolvedTypeToJson (RVar path) = Object (KeyMap.fromList [("kind", String "var"), ("path", Array (V.fromList (map String path)))])

-- | A @\"type-constraints\"@ entry (v4-types \S8): a name and its resolved
-- arguments, a type argument rendered as the erased @{\"$type\": ...}@ tag
-- \S7 already reserves so a host reads both lists the same way, a scalar
-- argument as the plain JSON it already is.
typeConstraintToJson :: (Text, [ResolvedConstraintArg]) -> Value
typeConstraintToJson (name, args) =
  Object (KeyMap.fromList [("name", String name), ("arguments", Array (V.fromList (map arg args)))])
  where
    arg (RCType rt) = Object (KeyMap.fromList [("$type", String (canonicalId rt))])
    arg (RCScalarStr s) = String s
    arg (RCScalarNum n) = Number (fromFloatDigits n)
    arg (RCScalarBool b) = Bool b
    arg RCScalarNull = Null

-- | A constraint's envelope rendering (v3-symbols \S5.2): its name and its
-- arguments, each already-evaluated to plain JSON, an argument that is
-- itself a symbol rendering as \S5.3's @{"$sym": ..., "path": [...]}@ tag
-- via 'toJson'.
constraintToJson :: Value' -> Value
constraintToJson (VConstraint name args) =
  Object
    ( KeyMap.fromList
        [ ("name", String name)
        , ("arguments", Array (V.fromList (map (either (const Null) id . toJson) args)))
        ]
    )
constraintToJson other = either (const Null) id (toJson other)

-- | A symbol table entry's envelope rendering (\S5.2): id, origin (the
-- structured form of the id, so a host never has to parse it) and binding.
symbolEntryToJson :: SymbolEntry -> Value
symbolEntryToJson (SymbolEntry sid origin binding) =
  Object
    ( KeyMap.fromList
        [ ("id", String sid)
        , ("origin", originToJson origin)
        , ("binding", maybe Null String binding)
        ]
    )
  where
    originToJson (OAlloc site key) =
      Object (KeyMap.fromList [("kind", String "alloc"), ("site", Number (fromIntegral site)), ("key", key)])
    originToJson (ODemand path) =
      Object (KeyMap.fromList [("kind", String "demand"), ("path", Array (V.fromList (map String path)))])

-- | Evaluates one expression against a context value, with the builtins in
-- scope -- the shared path 'evalProgram' and library evaluation both take.
-- Any emissions reached are discarded; callers that need them should use
-- 'evalExpr' directly inside 'Eval'.
evalExprWith :: Mode -> LibraryTable -> Value' -> Expr -> Either EvalError Value'
evalExprWith mode libs ctx e =
  fst <$> runEval (evalExpr (EvalCtx {ecLibs = libs, ecInProgress = Set.empty, ecMode = mode, ecIsRoot = True}) (initialEnv ctx) e)

initialEnv :: Value' -> Env
initialEnv ctx = Map.insert "ctx" ctx (Map.fromList [(n, VBuiltin n) | n <- builtinNames])

-- | The fixed builtin vocabulary. Builtins are ordinary values in the initial
-- environment rather than a separate call form, so @cardinality($xs)@,
-- @$f($x)@ and @map($xs, $not)@ all go through 'Call'.
builtinNames :: [Text]
builtinNames =
  [ "cardinality"
  , "count"
  , "str"
  , "not"
  , "and"
  , "or"
  , "eq"
  , "lt"
  , "lte"
  , "gt"
  , "gte"
  , "has"
  , "lookup"
  , "concat"
  , "append"
  ]

-- Core evaluation ------------------------------------------------------------

evalExpr :: EvalCtx -> Env -> Expr -> Eval Value'
evalExpr ctx env (Path root fields) = case Map.lookup root env of
  Nothing -> evalError (UnboundName root)
  Just v -> walkFields ctx (root : fields) v fields
evalExpr ctx env (FieldAccess target fields) = do
  v <- evalExpr ctx env target
  walkFields ctx fields v fields
evalExpr ctx env (Call fnExpr argExprs) = do
  fnVal <- evalExpr ctx env fnExpr
  argVals <- traverse (evalExpr ctx env) argExprs
  apply ctx (describeCallee fnExpr) fnVal argVals
evalExpr _ env (Lambda params body) = pure (VClosure params body env)
-- | @\@name=?(k)@ or @\@name=?ctx.path@ binds the allocation\/demand directly
-- to a name, which is what the symbol table's @"binding"@ field (\S5.2)
-- reports; anything else evaluates exactly as it always has. Routed through
-- 'evalBindable' rather than special-cased here so a standalone 'Alloc'\/
-- 'Demand' (used inline, with no binding) shares the same minting logic.
evalExpr ctx env (Let name valueExpr body) = do
  v <- evalBindable ctx env (if isHiddenName name then Nothing else Just name) valueExpr
  evalExpr ctx (Map.insert name v env) body
evalExpr _ _ (StringLit s) = pure (VString s)
evalExpr _ _ (NumberLit n) = pure (VNumber (fromFloatDigits n))
evalExpr _ _ (BoolLit b) = pure (VBool b)
evalExpr _ _ NullLit = pure VNull
evalExpr ctx env (ArrayLit elems) =
  VArray <$> traverse (evalExpr ctx env) elems
evalExpr ctx env (ObjectLit entries) =
  VObject . Map.fromList <$> traverse (\(k, e) -> (,) k <$> evalExpr ctx env e) entries
evalExpr ctx env (Element tag attrs valExpr children) = do
  attrs' <- traverse (evalAttribute ctx env) attrs
  val <- evalExpr ctx env valExpr >>= liftEither . toJson
  children' <- evalChildren ctx env children
  pure (VNode' (NElement tag attrs' val children' noAnnotations))
evalExpr ctx env (Fragment children) =
  VNode' . flip NFragment noAnnotations <$> evalChildren ctx env children
-- | The one non-eager form in the language: the arm not selected is never
-- evaluated, so an error inside it never surfaces.
evalExpr ctx env (Branch condExpr thenExpr elseExpr) = do
  cond <- evalExpr ctx env condExpr >>= liftEither . requireBool "a branch condition"
  evalExpr ctx env (if cond then thenExpr else elseExpr)
evalExpr ctx env (Map collExpr fnExpr) = do
  items <- evalCollection ctx env "map" collExpr
  fnVal <- evalExpr ctx env fnExpr
  VArray <$> traverse (\item -> apply ctx "map" fnVal [item]) items
evalExpr ctx env (Filter collExpr fnExpr) = do
  items <- evalCollection ctx env "filter" collExpr
  fnVal <- evalExpr ctx env fnExpr
  kept <- traverse (\item -> (,) item <$> (apply ctx "filter" fnVal [item] >>= liftEither . requireBool "a filter predicate")) items
  pure (VArray [item | (item, True) <- kept])
evalExpr ctx env (Scan collExpr initExpr fnExpr) = do
  items <- evalCollection ctx env "scan" collExpr
  acc0 <- evalExpr ctx env initExpr
  fnVal <- evalExpr ctx env fnExpr
  VArray <$> scanSteps ctx fnVal acc0 items
evalExpr ctx env (Fold collExpr initExpr fnExpr) = do
  items <- evalCollection ctx env "fold" collExpr
  acc0 <- evalExpr ctx env initExpr
  fnVal <- evalExpr ctx env fnExpr
  foldSteps ctx fnVal acc0 items
evalExpr ctx env (Concat leftExpr rightExpr) = do
  l <- evalExpr ctx env leftExpr
  r <- evalExpr ctx env rightExpr
  liftEither (concatValues l r)
-- | Wiring up an import evaluates its parameters and stops there. The library
-- itself runs later, when a field is read off the result, so parameters can
-- keep arriving in between.
--
-- @ctx(path)@ is substituted here, from the /importing/ program's own context
-- -- exactly what @$ctx.path@ would read, including the same 'PathNotFound'
-- when it is absent, which is why it evaluates as that very expression. It is
-- a distinct AST node purely so "Tramaj.Analysis" can read every hole off the
-- source without evaluating anything; the evaluator gains nothing from the
-- distinction and deliberately makes no other use of it.
-- | A @%@-marked entry (v4-types \S2) supplies a type, not a value, so it
-- never reaches the library's own @$ctx@ -- 'resolveParam' drops it, the
-- same way 'pParams' never has a slot for it, rather than passing some inert
-- placeholder through: the two channels sharing one params record share no
-- runtime representation at all, one being erased entirely before
-- evaluation (\S7).
evalExpr ctx env (Import name params) = do
  supplied <- catMaybes <$> traverse resolveParam params
  pure (VImport (Pending name (Map.fromList supplied) []))
  where
    resolveParam (k, PExpr e) = Just . (,) k <$> evalExpr ctx env e
    resolveParam (k, PFromContext path) = Just . (,) k <$> evalExpr ctx env (Path "ctx" path)
    resolveParam (_, PType _) = pure Nothing
evalExpr ctx env (AdaptActions targetExpr adaptation fnExpr) = do
  target <- evalExpr ctx env targetExpr
  fnVal <- traverse (evalExpr ctx env) fnExpr
  adaptValue ctx adaptation fnVal target
-- | @constraint(name, args...)@ (v3-symbols \S2.1). Each argument must be
-- something that can cross a JSON boundary -- the same rule 'toJson' already
-- enforces everywhere else -- checked here and not deferred, since a
-- constraint carrying a closure would otherwise sit unnoticed until whatever
-- @!@ eventually reaches it, or never surface at all if none does.
evalExpr ctx env (Constrain name argExprs) = do
  argVals <- traverse (evalExpr ctx env) argExprs
  liftEither (traverse_ toJson argVals)
  pure (VConstraint name argVals)
-- | @!expr@ (\S2.2): evaluates the constraint expression, collects from its
-- value by the coercion table 'collectConstraints' encodes, records what it
-- collected, then continues into the body -- the same "earlier bindings
-- only" shape 'Let' already has, since both nest into one chain.
evalExpr ctx env (Emit constraintExpr body) = do
  cv <- evalExpr ctx env constraintExpr
  collected <- liftEither (collectConstraints cv)
  tellConstraints collected
  evalExpr ctx env body
evalExpr ctx env e@(Alloc _ _) = evalBindable ctx env Nothing e
evalExpr ctx env e@(Demand _) = evalBindable ctx env Nothing e
-- | @type Name = TypeExpr@ (v4-types \S1.1, roadmap Phase 8): means nothing
-- to evaluation -- resolution is a static pass (v4-types \S9) -- so this
-- simply continues into the body.
evalExpr ctx env (TypeDecl _ _ body) = evalExpr ctx env body
-- | Every entry point below ('evalProgramWithEmissions', 'runLibrary') runs
-- "Tramaj.Types"\'s erasure pass before ever calling 'evalExpr', which
-- rewrites every 'TypeAnnotate' into the 'Let'\/'Emit' pair v4-types \S7
-- specifies -- so this case is not the normal path. It is kept total anyway,
-- exactly as 'TypeDecl'\'s case is total on purpose: matching what erasure
-- would have produced, minus the emission, keeps 'evalExpr' correct even if
-- a caller somehow reaches it pre-erasure, rather than leaving a partial
-- match for that case to crash on.
evalExpr ctx env (TypeAnnotate name _ valueExpr body) = evalExpr ctx env (Let name valueExpr body)
-- | @!type-constraint(...)@ (v4-types \S5, roadmap Phase 12): resolved by
-- the analyser, never evaluated -- \S5.1 is explicit that the evaluator's
-- statement fold skips this, exactly as it skips 'TypeDecl'.
evalExpr ctx env (TypeEmit _ _ body) = evalExpr ctx env body

-- | 'Alloc' and 'Demand' are the two forms whose symbol-table entry records
-- the name they were bound to, or 'Nothing' when used inline (v3-symbols
-- \S5.2's @"binding"@ field) -- everything else evaluates through plain
-- 'evalExpr', unaffected by whether it happens to sit on a 'Let'\'s
-- right-hand side.
evalBindable :: EvalCtx -> Env -> Maybe Text -> Expr -> Eval Value'
evalBindable ctx env binding (Alloc site keyExpr) = evalAlloc ctx env binding site keyExpr
evalBindable ctx env binding (Demand path) = evalDemand ctx env binding path
evalBindable ctx env _ other = evalExpr ctx env other

-- | @?(key)@ (\S1.2, \S4): the key is evaluated first, in both modes alike --
-- so an error inside it surfaces the same way regardless of mode -- and
-- only /minting/ depends on the mode (\S5.1): concrete mode has no way to
-- represent the result, symbolic mode allocates and records the entry.
evalAlloc :: EvalCtx -> Env -> Maybe Text -> Int -> Expr -> Eval Value'
evalAlloc ctx env binding site keyExpr = do
  keyVal <- evalExpr ctx env keyExpr
  keyJson <- liftEither (requireConcrete "?(...)" keyVal)
  case ecMode ctx of
    Concrete -> evalError SymbolsUnavailable
    Symbolic -> do
      let sid = "#" <> tshow site <> ":" <> canon keyJson
      tellSymbol (SymbolEntry sid (OAlloc site keyJson) binding)
      pure (VSymbol sid [])

-- | @?ctx.a.b@ (\S1.3): reads exactly as @$ctx.a.b@ would when the path is
-- supplied, in either mode -- 'tryEval' only ever looks past a
-- 'PathNotFound' it raises. Unsupplied, it allocates at the root (mode
-- permitting) and is an ordinary unsupplied read anywhere else, which
-- 'mapEvalError' in 'runLibrary' already tags with 'InLibrary'.
evalDemand :: EvalCtx -> Env -> Maybe Text -> [Text] -> Eval Value'
evalDemand ctx env binding path = do
  attempt <- tryEval (evalExpr ctx env (Path "ctx" path))
  case attempt of
    Right v -> pure v
    Left (PathNotFound _) | ecIsRoot ctx -> case ecMode ctx of
      Concrete -> evalError SymbolsUnavailable
      Symbolic -> do
        let sid = "#ctx" <> mconcat (map ("." <>) path)
        tellSymbol (SymbolEntry sid (ODemand path) binding)
        pure (VSymbol sid [])
    Left e -> evalError e

-- | Runs an 'Eval' computation and reports whether it failed, without
-- discarding whatever it had already accumulated on success. Used only to
-- look past a 'PathNotFound' that might mean "allocate instead" -- every
-- other error still propagates once inspected.
tryEval :: Eval a -> Eval (Either EvalError a)
tryEval (MkEval e) = MkEval $ case e of
  Left err -> Right (Left err, mempty)
  Right (a, w) -> Right (Right a, w)

-- | The coercion table a @!@ collects by (v3-symbols \S2.2): a constraint
-- contributes itself; an array contributes each element, recursively, which
-- is why @!map(...)@ and @!$cs@ (a binding holding an array built earlier)
-- both read naturally; anything else is a 'TypeMismatch'.
collectConstraints :: Value' -> Either EvalError [Value']
collectConstraints v@(VConstraint _ _) = Right [v]
collectConstraints (VArray xs) = concat <$> traverse collectConstraints xs
collectConstraints other = Left (TypeMismatch ("! expects a constraint or an array of them, got " <> describeValue other))

-- | Only for error messages: what the source called, as written.
describeCallee :: Expr -> Text
describeCallee (Path root fields) = T.intercalate "." (root : fields)
describeCallee _ = "a call"

-- Documents -------------------------------------------------------------------

evalAttribute :: EvalCtx -> Env -> Attribute -> Eval NodeAttribute
evalAttribute ctx env (Attr name e) = NAttr name <$> (evalExpr ctx env e >>= liftEither . toJson)
evalAttribute ctx env (ActionAttr event key payloadExpr) =
  NAction event key <$> (evalExpr ctx env payloadExpr >>= liftEither . toJson)

evalChildren :: EvalCtx -> Env -> [Expr] -> Eval [Node]
evalChildren ctx env children =
  concat <$> traverse (\e -> evalExpr ctx env e >>= liftEither . childNodes) children

-- | How a value becomes children. A node is itself one child; an array
-- contributes each of its elements, which is how @map(...)@ produces repeated
-- siblings without a document-specific map form; anything else becomes a text
-- node carrying that value unconverted, so a number child stays a number.
--
-- A closure, an unfinished import or a constraint has no rendering, and
-- 'toJson' says so -- a 'VConstraint' reaching here is exactly \S2.1's rule
-- that a constraint MUST NOT cross a JSON boundary, including as a child.
childNodes :: Value' -> Either EvalError [Node]
childNodes (VNode' n) = Right [n]
childNodes (VArray xs) = concat <$> traverse childNodes xs
childNodes v = (\j -> [NText j noAnnotations]) <$> toJson v

-- Application ------------------------------------------------------------------

apply :: EvalCtx -> Text -> Value' -> [Value'] -> Eval Value'
apply ctx _ (VClosure params body closureEnv) args
  | length params /= length args =
      evalError (TypeMismatch ("closure expects " <> tshow (length params) <> " argument(s), got " <> tshow (length args)))
  | otherwise =
      evalExpr ctx (foldl' (\e (p, v) -> Map.insert p v e) closureEnv (zip params args)) body
apply _ _ (VBuiltin name) args = liftEither (evalBuiltin name args)
-- | Saturating an import: the argument is more parameters, merged over what it
-- already has. Right-biased, like @\<\>@ on objects, so a later call overrides
-- an earlier value for the same name -- which is what makes one wired-up
-- import reusable across a @map@, each iteration supplying its own.
apply _ who (VImport pending) args = case args of
  [VObject more] -> pure (VImport pending {pParams = Map.union more (pParams pending)})
  [other] ->
    evalError
      ( TypeMismatch
          (who <> ": the import of " <> tshow (pName pending) <> " takes an object of parameters, got " <> describeValue other)
      )
  _ -> evalError (TypeMismatch (who <> ": the import of " <> tshow (pName pending) <> " expects exactly 1 argument, the parameters to add"))
apply _ who v _ = evalError (TypeMismatch (who <> " is not callable: " <> describeValue v))

-- | @scan@'s output is @[init, f(init, x1), f(f(init, x1), x2), ...]@ --
-- @scanl@, not @scanl1@.
scanSteps :: EvalCtx -> Value' -> Value' -> [Value'] -> Eval [Value']
scanSteps _ _ acc [] = pure [acc]
scanSteps ctx fnVal acc (item : rest) = do
  next <- apply ctx "scan" fnVal [acc, item]
  (acc :) <$> scanSteps ctx fnVal next rest

-- | The same steps as 'scanSteps', keeping only the final accumulator.
foldSteps :: EvalCtx -> Value' -> Value' -> [Value'] -> Eval Value'
foldSteps _ _ acc [] = pure acc
foldSteps ctx fnVal acc (item : rest) = do
  next <- apply ctx "fold" fnVal [acc, item]
  foldSteps ctx fnVal next rest

evalCollection :: EvalCtx -> Env -> Text -> Expr -> Eval [Value']
evalCollection ctx env who e =
  evalExpr ctx env e >>= \case
    VArray xs -> pure xs
    VSymbol _ _ -> evalError (NotConcrete who)
    other -> evalError (TypeMismatch (who <> " expects an array as its first argument, got " <> describeValue other))

-- Concat -------------------------------------------------------------------------

-- | The monoid operation over the three types that have one. Mixed types are
-- an error rather than a coercion, and objects merge right-biased. Either
-- side being a symbol is 'NotConcrete' (v3-symbols \S1.5), ahead of the
-- generic mismatch: the spine of a concatenation must be known, unlike an
-- element it might merely carry.
concatValues :: Value' -> Value' -> Either EvalError Value'
concatValues (VSymbol _ _) _ = Left (NotConcrete "<>")
concatValues _ (VSymbol _ _) = Left (NotConcrete "<>")
concatValues (VString a) (VString b) = Right (VString (a <> b))
concatValues (VArray a) (VArray b) = Right (VArray (a <> b))
concatValues (VObject a) (VObject b) = Right (VObject (Map.union b a))
concatValues l r = Left (ConcatMismatch (describeValue l) (describeValue r))

-- Imports --------------------------------------------------------------------------

-- | Runs the library behind an import, against the parameters it has
-- accumulated, and applies whatever adaptations were queued on it.
--
-- This is the only place a library runs, and 'walkFields' is the only caller:
-- an import runs when a field is read off it, never where it is written.
-- Nothing checks first whether the parameters are enough -- there is no list
-- of what "enough" would be. A library that reads a @$ctx@ path nobody
-- supplied fails with its own 'PathNotFound', tagged by 'runLibrary' with the
-- library's name.
forceImport :: EvalCtx -> Pending -> Eval Value'
forceImport ctx pending = do
  result <- runLibrary ctx (pName pending) (VObject (pParams pending))
  applyQueued ctx (pQueued pending) result

-- | Evaluates a library against its own fresh @$ctx@ -- the parameters it was
-- given -- and exposes @{rendered, vals}@. @inProgress@ carries the libraries
-- already being evaluated on this chain, so re-entering one is reported as a
-- cycle instead of running forever.
--
-- Bindings are replayed by hand, via 'foldlEval' over 'bindStep', rather than
-- letting a single 'evalExpr' over the whole chain produce @rendered@:
-- that is what exposes each binding's own value for @.vals@ without a
-- separate environment-inspection mechanism. Any @!@ interleaved among the
-- bindings (v3-symbols \S2.3 -- "a library's emissions are collected ... when
-- a field is read off its import") is replayed the same way, in the same
-- pass, so its constraints are collected exactly once, at its position in
-- the chain -- this is the fix for the 'unlets' trap: the old version simply
-- stopped at the first non-'Let', which silently dropped both the bindings
-- after a @!@ and the @!@'s own constraint.
runLibrary :: EvalCtx -> Text -> Value' -> Eval Value'
runLibrary ctx name ctxVal
  | Set.member name (ecInProgress ctx) = evalError (ImportCycle name)
  | otherwise = do
      rawProg <- liftEither (maybe (Left (UnknownLibrary name)) Right (Map.lookup name (ecLibs ctx)))
      liftEither (if Set.null (symbolSites rawProg) then Right () else Left (AllocationInLibrary name))
      prog <- liftEither (first TypeErr (eraseTypes (ecLibs ctx) rawProg))
      mapEvalError (InLibrary name) $ do
        let ctx' = enterLibrary name ctx
            (statements, root) = unlets (programRoot prog)
        libEnv <- foldlEval (bindStep ctx') (initialEnv ctxVal) statements
        rendered <- evalExpr ctx' libEnv root
        let bindings = filter (not . isHiddenName . fst) (letBindings statements)
        pure (VEnv (Map.fromList [("rendered", rendered), ("vals", VEnv (Map.fromList (map (\(n, _) -> (n, libEnv Map.! n)) bindings)))]))
  where
    bindStep ctx' env (SLet n e) = do
      v <- evalExpr ctx' env e
      pure (Map.insert n v env)
    bindStep ctx' env (SEmit e) = do
      cv <- evalExpr ctx' env e
      collected <- liftEither (collectConstraints cv)
      tellConstraints collected
      pure env
    -- | A type declaration means nothing to the evaluator (v4-types, roadmap
    -- Phase 8) -- it exists for static resolution alone, so replaying it here
    -- is a no-op on the environment.
    bindStep _ env (STypeDecl _ _) = pure env
    -- | See 'evalExpr'\'s 'TypeAnnotate' case: erasure has already turned
    -- this into a 'SLet' plus 'SEmit' by the time a library's own chain gets
    -- here, so this branch, like that one, only guards totality.
    bindStep ctx' env (SAnnotate n _ e) = do
      v <- evalExpr ctx' env e
      pure (Map.insert n v env)
    -- | See 'evalExpr'\'s 'TypeEmit' case: never evaluated.
    bindStep _ env (STypeEmit _ _) = pure env

-- Action adaptation -------------------------------------------------------------------

-- | Applies an adaptation everywhere it can reach: through a node's whole
-- tree, through every value of an import result (not just @rendered@), and
-- through arrays. An import that has not run has no actions yet, so the
-- adaptation is queued and runs on its result. Anything else has no actions
-- and passes through untouched.
adaptValue :: EvalCtx -> ActionAdaptation -> Maybe Value' -> Value' -> Eval Value'
adaptValue ctx adaptation fnVal = go
  where
    go (VNode' n) = VNode' <$> mapActions (adaptAction ctx adaptation fnVal) n
    go (VEnv e) = VEnv <$> traverse go e
    go (VArray xs) = VArray <$> traverse go xs
    go (VObject o) = VObject <$> traverse go o
    go (VImport pending) = pure (VImport pending {pQueued = pQueued pending <> [(adaptation, fnVal)]})
    go v = pure v

applyQueued :: EvalCtx -> [(ActionAdaptation, Maybe Value')] -> Value' -> Eval Value'
applyQueued ctx queued v0 =
  foldlEval (\v (adaptation, fnVal) -> adaptValue ctx adaptation fnVal v) v0 queued

-- | One action, adapted. The key is rewritten first, unconditionally, by the
-- static adaptation; the optional closure then sees the already-adapted action
-- and may change only its event type and payload. A @key@ in the closure's
-- result is ignored -- letting it win would put the action vocabulary back
-- beyond static reach, which is the whole point of restricting adaptation.
adaptAction :: EvalCtx -> ActionAdaptation -> Maybe Value' -> Text -> Text -> Value -> Eval NodeAttribute
adaptAction ctx adaptation fnVal event key payload =
  case fnVal of
    Nothing -> pure (NAction event key' payload)
    Just fn -> do
      result <- apply ctx "adapt-actions" fn [actionAsValue] >>= liftEither . toJson
      case result of
        Object obj -> do
          event' <- liftEither $ case KeyMap.lookup (Key.fromText "eventType") obj of
            Just (String s) -> Right s
            _ -> Left (TypeMismatch "adapt-actions: the function's result needs a string \"eventType\" field")
          let payload' = maybe Null id (KeyMap.lookup (Key.fromText "payload") obj)
          pure (NAction event' key' payload')
        _ -> evalError (TypeMismatch "adapt-actions: the function must return an object with an eventType field")
  where
    key' = adaptKey adaptation key
    actionAsValue =
      VObject
        (Map.fromList [("eventType", VString event), ("key", VString key'), ("payload", fromJson payload)])

-- Paths and fields -----------------------------------------------------------------------

-- | Walks named segments into a value. @context@ is the full path as written,
-- for error messages only.
walkFields :: EvalCtx -> [Text] -> Value' -> [Text] -> Eval Value'
walkFields _ _ v [] = pure v
walkFields ctx context v fields@(field : rest) = case v of
  VObject o -> case Map.lookup field o of
    Nothing -> evalError (PathNotFound context)
    Just v' -> walkFields ctx context v' rest
  VEnv e -> case Map.lookup field e of
    Nothing -> evalError (PathNotFound context)
    Just v' -> walkFields ctx context v' rest
  -- Reading a field off an import is what runs it -- @.rendered@ and @.vals@
  -- are fields of the result, so the same segment is then walked into that
  -- result rather than consumed here.
  VImport pending -> do
    result <- forceImport ctx pending
    walkFields ctx context result fields
  -- Projection (v3-symbols \S1.6): reads nothing, and is never rejected --
  -- whether the thing a symbol stands for has this field is a question for
  -- whoever owns its meaning, not the language. Consumes every remaining
  -- segment at once, since a projection just extends the path.
  VSymbol sid path -> pure (VSymbol sid (path <> fields))
  other ->
    evalError
      ( TypeMismatch
          ("cannot read field " <> tshow field <> " of " <> describeValue other <> " in path " <> tshow (T.intercalate "." context))
      )

-- Conversion ------------------------------------------------------------------------------

-- | Down to JSON, at the boundaries where only JSON is meaningful: an
-- attribute value, an action payload, an element's value slot, an expression
-- program's result.
--
-- The values that cannot cross say why. A node is deliberately included:
-- documents nest as children, not as attribute values, and silently
-- serializing one here would hide a mistake rather than report it.
toJson :: Value' -> Either EvalError Value
toJson VNull = Right Null
toJson (VBool b) = Right (Bool b)
toJson (VNumber n) = Right (Number n)
toJson (VString s) = Right (String s)
toJson (VArray xs) = Array . V.fromList <$> traverse toJson xs
toJson (VObject o) = Object . KeyMap.fromList <$> traverse (\(k, v) -> (,) (Key.fromText k) <$> toJson v) (Map.toList o)
toJson (VNode' _) = Left (TypeMismatch "a document node is not a plain value -- nest it as a child rather than using it where a value is expected")
toJson (VConstraint name _) = Left (TypeMismatch ("a constraint (" <> tshow name <> ") cannot cross a JSON boundary -- only \"!\" may consume it"))
-- | A symbol may sit in an attribute, a payload, a value slot or a text
-- child (v3-symbols \S1.5), so this always succeeds -- it is 'requireConcrete'
-- that refuses one, for the handful of forms that need to. \S5.3's tagged
-- shape: both fields required, matching what the decoder in
-- 'checkedFromJson' accepts back.
toJson (VSymbol sid path) =
  Right (Object (KeyMap.fromList [("$sym", String sid), ("path", Array (V.fromList (map String path)))]))
toJson (VClosure _ _ _) = Left (TypeMismatch "expected a value, got a function -- call it first, e.g. $my-fn(...)")
toJson (VBuiltin name) = Left (TypeMismatch ("expected a value, got the builtin " <> tshow name <> " -- call it first"))
toJson (VEnv _) = Left (TypeMismatch "expected a value, got an import result -- read .rendered, .vals, or a binding name from it first")
toJson (VImport pending) =
  Left
    ( TypeMismatch
        ( "expected a value, got the import of "
            <> tshow (pName pending)
            <> " -- read .rendered or .vals from it to run it first"
        )
    )

fromJson :: Value -> Value'
fromJson Null = VNull
fromJson (Bool b) = VBool b
fromJson (Number n) = VNumber n
fromJson (String s) = VString s
fromJson (Array arr) = VArray (map fromJson (V.toList arr))
fromJson (Object obj) = VObject (Map.fromList (map (\(k, v) -> (Key.toText k, fromJson v)) (KeyMap.toList obj)))

-- | The input context's boundary: as 'fromJson', but recursively refusing
-- @"$sym"@ and @"$type"@ as ordinary object keys (v3-symbols \S5.3). In
-- concrete mode either key is refused unconditionally. In symbolic mode,
-- seeding (\S5.4) accepts a well-formed @{"$sym": ..., "path": [...]}@ back
-- as an actual symbol -- anything else carrying @"$sym"@, or @"$type"@ at
-- all (v3 has no valid shape for it yet), is still refused.
checkedFromJson :: Mode -> Value -> Either EvalError Value'
checkedFromJson _ Null = Right VNull
checkedFromJson _ (Bool b) = Right (VBool b)
checkedFromJson _ (Number n) = Right (VNumber n)
checkedFromJson _ (String s) = Right (VString s)
checkedFromJson mode (Array arr) = VArray <$> traverse (checkedFromJson mode) (V.toList arr)
checkedFromJson mode (Object obj)
  | KeyMap.member (Key.fromText "$type") obj =
      Left (TypeMismatch "the context carries the reserved key \"$type\", which only a typed envelope may use")
  | Just symVal <- KeyMap.lookup (Key.fromText "$sym") obj =
      case mode of
        Concrete -> Left (TypeMismatch "the context carries the reserved key \"$sym\", which only a symbolic envelope may use")
        Symbolic -> case (symVal, KeyMap.toList (KeyMap.delete (Key.fromText "$sym") obj)) of
          (String sid, [("path", Array pathArr)]) -> do
            path <- traverse expectString (V.toList pathArr)
            Right (VSymbol sid path)
          _ -> Left (TypeMismatch "a \"$sym\" object must be exactly {\"$sym\": <id>, \"path\": [<segment>, ...]}")
  | otherwise =
      VObject . Map.fromList <$> traverse (\(k, v) -> (,) (Key.toText k) <$> checkedFromJson mode v) (KeyMap.toList obj)
  where
    expectString (String s) = Right s
    expectString _ = Left (TypeMismatch "a symbol reference's \"path\" must be an array of strings")

describeValue :: Value' -> Text
describeValue VNull = "null"
describeValue (VBool _) = "a boolean"
describeValue (VNumber _) = "a number"
describeValue (VString _) = "a string"
describeValue (VArray _) = "an array"
describeValue (VObject _) = "an object"
describeValue (VNode' _) = "a document node"
describeValue (VClosure _ _ _) = "a function"
describeValue (VBuiltin name) = "the builtin " <> tshow name
describeValue (VEnv _) = "an import result"
describeValue (VImport pending) = "the not-yet-run import of " <> tshow (pName pending)
describeValue (VConstraint name _) = "a constraint (" <> tshow name <> ")"
describeValue (VSymbol _ _) = "a symbol"

-- | Control flow must be concrete (v3-symbols \S1.5): a symbolic condition is
-- 'NotConcrete', not merely the wrong type.
requireBool :: Text -> Value' -> Either EvalError Bool
requireBool _ (VBool b) = Right b
requireBool who (VSymbol _ _) = Left (NotConcrete who)
requireBool who other = Left (TypeMismatch (who <> " must be a boolean, got " <> describeValue other))

-- | Whether a value is, or contains, a symbol -- what makes a value
-- concrete's negation (\S1.5, \S1.7): a structure built of concrete pieces is
-- itself concrete and every structural operation on it works as normal;
-- only a symbol itself, wherever it sits, makes the whole not concrete.
containsSymbol :: Value' -> Bool
containsSymbol (VSymbol _ _) = True
containsSymbol (VArray xs) = any containsSymbol xs
containsSymbol (VObject o) = any containsSymbol (Map.elems o)
containsSymbol _ = False

-- | Requires a value with no symbol anywhere in it, for the handful of
-- operations \S1.5 lists as needing to *know* something about their
-- argument rather than merely carry it: @str@, @eq@, and an allocation key.
-- Everything else about crossing a JSON boundary is 'toJson'\'s ordinary
-- business, which this defers to once a symbol is ruled out.
requireConcrete :: Text -> Value' -> Either EvalError Value
requireConcrete who v
  | containsSymbol v = Left (NotConcrete who)
  | otherwise = toJson v

-- | v3-symbols \S1.4: compact JSON with keys sorted, agreeing with @str@ on
-- arrays and objects and differing at the top level for strings, where
-- @str@ renders raw and this quotes -- the difference that makes it
-- injective. This is exactly 'compactJson', which already quotes a string
-- unconditionally; the two are one function under two names because they
-- serve the same requirement (\S1.4's canon, \S6's @str@) for the same
-- reason.
canon :: Value -> Text
canon = compactJson

tshow :: (Show a) => a -> Text
tshow = T.pack . show

-- Builtins ------------------------------------------------------------------------------------

-- | A fixed vocabulary, grown only on real demand. @branch@ is absent
-- deliberately: it has to leave an arm unevaluated, which no builtin can do,
-- so it is a core constructor instead.
evalBuiltin :: Text -> [Value'] -> Either EvalError Value'
evalBuiltin name args = case name of
  "cardinality" -> cardinality
  "count" -> cardinality
  "str" -> arity1 (fmap (VString . displayString) . requireConcrete name)
  "not" -> arity1 (fmap (VBool . not) . asBool)
  "and" -> variadicBool (&&) True
  "or" -> variadicBool (||) False
  "eq" -> binary (\a b -> VBool <$> ((==) <$> requireConcrete name a <*> requireConcrete name b))
  "lt" -> comparison (<)
  "lte" -> comparison (<=)
  "gt" -> comparison (>)
  "gte" -> comparison (>=)
  "has" -> binary hasImpl
  "lookup" -> ternary lookupImpl
  "concat" -> concatImpl
  "append" -> binary appendImpl
  _ -> Left (UnboundName name)
  where
    arity1 :: (Value' -> Either EvalError a) -> Either EvalError a
    arity1 f = case args of
      [a] -> f a
      _ -> Left (TypeMismatch (name <> " expects exactly 1 argument, got " <> tshow (length args)))

    binary :: (Value' -> Value' -> Either EvalError Value') -> Either EvalError Value'
    binary f = case args of
      [a, b] -> f a b
      _ -> Left (TypeMismatch (name <> " expects exactly 2 arguments, got " <> tshow (length args)))

    ternary :: (Value' -> Value' -> Value' -> Either EvalError Value') -> Either EvalError Value'
    ternary f = case args of
      [a, b, c] -> f a b c
      _ -> Left (TypeMismatch (name <> " expects exactly 3 arguments, got " <> tshow (length args)))

    cardinality :: Either EvalError Value'
    cardinality = arity1 $ \case
      VArray xs -> Right (VNumber (fromIntegral (length xs)))
      VObject o -> Right (VNumber (fromIntegral (Map.size o)))
      VSymbol _ _ -> Left (NotConcrete name)
      other -> Left (TypeMismatch (name <> " expects an array or object, got " <> describeValue other))

    asBool :: Value' -> Either EvalError Bool
    asBool (VBool b) = Right b
    asBool other = Left (TypeMismatch (name <> " expects a boolean argument, got " <> describeValue other))

    asNumber :: Value' -> Either EvalError Scientific
    asNumber (VNumber n) = Right n
    asNumber (VSymbol _ _) = Left (NotConcrete name)
    asNumber other = Left (TypeMismatch (name <> " expects a number argument, got " <> describeValue other))

    asArray :: Value' -> Either EvalError [Value']
    asArray (VArray xs) = Right xs
    asArray other = Left (TypeMismatch (name <> " expects an array argument, got " <> describeValue other))

    -- | @and@\/@or@ fold over however many arguments they are given, zero
    -- included (vacuously), rather than fixing an arity.
    variadicBool :: (Bool -> Bool -> Bool) -> Bool -> Either EvalError Value'
    variadicBool op identityVal = VBool . foldl' op identityVal <$> traverse asBool args

    comparison :: (Scientific -> Scientific -> Bool) -> Either EvalError Value'
    comparison op = binary $ \a b -> VBool <$> (op <$> asNumber a <*> asNumber b)

    -- | Deliberately tolerant: a missing key, an out-of-range index, or a
    -- container of the wrong shape all answer @false@ rather than erroring
    -- -- except a symbolic container, which is 'NotConcrete' rather than a
    -- lie (v3-symbols \S1.5): the tolerant @false@ would claim to know
    -- something about a container the language cannot see into.
    hasImpl :: Value' -> Value' -> Either EvalError Value'
    hasImpl (VSymbol _ _) _ = Left (NotConcrete name)
    hasImpl container key = Right . VBool $ case (container, key) of
      (VObject o, VString k) -> Map.member k o
      (VArray xs, VNumber n) -> maybe False (\i -> i >= 0 && i < length xs) (asIndex n)
      _ -> False

    -- | Dynamic access by a computed key or index -- the counterpart to a
    -- static path segment. The third argument is the mandatory fallback. A
    -- symbolic container is 'NotConcrete' rather than falling back, which
    -- would silently discard the symbol (\S1.5).
    lookupImpl :: Value' -> Value' -> Value' -> Either EvalError Value'
    lookupImpl (VSymbol _ _) _ _ = Left (NotConcrete name)
    lookupImpl container key fallback = Right $ case (container, key) of
      (VObject o, VString k) -> maybe fallback id (Map.lookup k o)
      (VArray xs, VNumber n) -> maybe fallback id (asIndex n >>= atIndex xs)
      _ -> fallback

    atIndex :: [Value'] -> Int -> Maybe Value'
    atIndex xs i
      | i >= 0 && i < length xs = Just (xs !! i)
      | otherwise = Nothing

    -- | An index must be a non-negative whole number: @2.5@ and @-1@ are not
    -- indices.
    asIndex :: Scientific -> Maybe Int
    asIndex n =
      let d = toRealFloat n :: Double
          i = round d :: Int
       in if fromIntegral i == d && i >= 0 then Just i else Nothing

    -- | Variadic array join, preserving order. @concat()@ is @[]@; a
    -- non-array argument anywhere is an error rather than being wrapped.
    concatImpl :: Either EvalError Value'
    concatImpl = VArray . concat <$> traverse asArray args

    -- | @append(arr, item)@ adds one element at the end. An array item is
    -- appended as a single element, not spliced -- @concat@ splices.
    appendImpl :: Value' -> Value' -> Either EvalError Value'
    appendImpl arr item = (\xs -> VArray (xs <> [item])) <$> asArray arr

-- | How a value reads when it is rendered into a string by @str@ (and so by
-- string interpolation): a string is itself, @null@ is empty, and anything
-- structured is compact JSON.
--
-- This is a normative rendering, not a debugging one, so it must agree
-- across implementations character for character -- it is what a template
-- interpolates into its output. See @../specs/reference.md@.
displayString :: Value -> Text
displayString Null = ""
displayString (Bool b) = if b then "true" else "false"
displayString (Number n) = formatNumber n
displayString (String s) = s
displayString v = compactJson v

-- | Compact JSON, with object keys in sorted order and numbers formatted by
-- 'formatNumber'.
--
-- Deliberately not aeson's own 'encode': that writes every number through
-- its 'Scientific' representation (@1.0@, @1.0e11@) where a JavaScript host
-- writes @1@ and @100000000000@, so using it here would leave two
-- conforming implementations rendering the same value differently. Keys are
-- sorted for the same reason -- object key order is not semantically
-- significant, so it must not be observable through @str@ either.
compactJson :: Value -> Text
compactJson Null = "null"
compactJson (Bool b) = if b then "true" else "false"
compactJson (Number n) = formatNumber n
compactJson (String s) = quoteString s
compactJson (Array xs) = "[" <> T.intercalate "," (map compactJson (V.toList xs)) <> "]"
compactJson (Object o) =
  "{" <> T.intercalate "," (map entry (sortOn fst (map (\(k, v) -> (Key.toText k, v)) (KeyMap.toList o)))) <> "}"
  where
    entry (k, v) = quoteString k <> ":" <> compactJson v

-- | A JSON string literal, escaped by aeson itself so this does not grow a
-- second, subtly different escaping table.
quoteString :: Text -> Text
quoteString = TL.toStrict . TLE.decodeUtf8 . encode . String

formatNumber :: Scientific -> Text
formatNumber = formatDouble . toRealFloat

-- | Formats a double exactly as ECMAScript's @Number::toString@ does.
--
-- Matching that specific algorithm is the point: the PureScript
-- implementation runs on a JavaScript host, where this is simply what a
-- number's text /is/. Haskell's own 'show' picks different thresholds for
-- scientific notation -- @0.05@ prints as @5.0e-2@, @1e11@ as @1.0e11@ --
-- so leaving it to 'show' would make the two implementations disagree on
-- something as ordinary as interpolating a price or a count.
--
-- NaN and infinities cannot reach here: JSON has no way to express them.
formatDouble :: Double -> Text
formatDouble d
  | isNaN d = "NaN"
  | isInfinite d = if d < 0 then "-Infinity" else "Infinity"
  | d == 0 = "0"
  | d < 0 = "-" <> formatPositive (negate d)
  | otherwise = formatPositive d

-- | The digit-placement rules of ECMA-262's @Number::toString@, given the
-- shortest round-tripping digit sequence @ds@ and exponent @n@ for which
-- the value is @0.ds * 10^n@ -- which is exactly what 'floatToDigits'
-- returns.
formatPositive :: Double -> Text
formatPositive d
  | n >= k && n <= 21 = digits <> T.replicate (n - k) "0"
  | n > 0 && n <= 21 = T.take n digits <> "." <> T.drop n digits
  | n > (-6) && n <= 0 = "0." <> T.replicate (negate n) "0" <> digits
  | otherwise = mantissa <> "e" <> sign <> tshow (abs e)
  where
    (ds, n) = floatToDigits 10 d
    k = length ds
    digits = T.pack (map intToDigit ds)
    e = n - 1
    mantissa = if k == 1 then digits else T.take 1 digits <> "." <> T.drop 1 digits
    sign = if e >= 0 then "+" else "-" :: Text