(* SPDX-License-Identifier: MPL-2.0 *)
(* SPDX-FileCopyrightText: 2024-2025 hyperpolymath *)

(** Tree-walking interpreter for AffineScript.

    This module implements a big-step operational semantics
    interpreter with affine type checking at runtime.
*)

open Ast
open Value

(** Result bind operator *)
let ( let* ) = Result.bind

(** Evaluate a literal *)
let eval_literal (lit : literal) : value =
  match lit with
  | LitUnit _ -> VUnit
  | LitBool (b, _) -> VBool b
  | LitInt (n, _) -> VInt n
  | LitFloat (f, _) -> VFloat f
  | LitChar (c, _) -> VChar c
  | LitString (s, _) -> VString s

(** Match a pattern against a value, returning bindings *)
let rec match_pattern (pat : pattern) (v : value) : (string * value) list result =
  match pat with
  | PatWildcard _ -> Ok []
  | PatVar id -> Ok [(id.name, v)]
  | PatLit lit ->
    let expected = eval_literal lit in
    if value_eq v expected then Ok []
    else Error PatternMatchFailure

  | PatTuple pats ->
    begin match v with
      | VTuple vs when List.length pats = List.length vs ->
        List.fold_left2 (fun acc pat v ->
          let* bindings = acc in
          let* new_bindings = match_pattern pat v in
          Ok (new_bindings @ bindings)
        ) (Ok []) pats vs
      | _ -> Error PatternMatchFailure
    end

  | PatRecord (fields, _has_rest) ->
    begin match v with
      | VRecord record_fields ->
        List.fold_left (fun acc (field_id, pat_opt) ->
          let* bindings = acc in
          match get_field field_id.name record_fields with
          | Ok field_val ->
            begin match pat_opt with
              | Some p ->
                let* new_bindings = match_pattern p field_val in
                Ok (new_bindings @ bindings)
              | None ->
                Ok ((field_id.name, field_val) :: bindings)
            end
          | Error _ -> Error PatternMatchFailure
        ) (Ok []) fields
      | _ -> Error PatternMatchFailure
    end

  | PatCon (con, pats) ->
    begin match v with
      | VVariant (tag, val_opt) when tag = con.name ->
        begin match (pats, val_opt) with
          | ([], None) -> Ok []
          | ([pat], Some val_) -> match_pattern pat val_
          | (pats, Some (VTuple vs)) when List.length pats = List.length vs ->
            List.fold_left2 (fun acc pat v ->
              let* bindings = acc in
              let* new_bindings = match_pattern pat v in
              Ok (new_bindings @ bindings)
            ) (Ok []) pats vs
          | _ -> Error PatternMatchFailure
        end
      | _ -> Error PatternMatchFailure
    end

  | PatOr (p1, p2) ->
    begin match match_pattern p1 v with
      | Ok bindings -> Ok bindings
      | Error _ -> match_pattern p2 v
    end

  | PatAs (id, pat) ->
    let* bindings = match_pattern pat v in
    Ok ((id.name, v) :: bindings)

(** Evaluate an expression *)
let rec eval (env : env) (expr : expr) : value result =
  match expr with
  | ExprLit lit -> Ok (eval_literal lit)

  | ExprVar id -> lookup_env id.name env

  | ExprLet lb ->
    let* rhs_val = eval env lb.el_value in
    let* bindings = match_pattern lb.el_pat rhs_val in
    let env' = extend_env_list bindings env in
    begin match lb.el_body with
      | Some body -> eval env' body
      | None -> Ok VUnit
    end

  | ExprIf ei ->
    let* cond_val = eval env ei.ei_cond in
    if is_truthy cond_val then
      eval env ei.ei_then
    else begin
      match ei.ei_else with
      | Some else_expr -> eval env else_expr
      | None -> Ok VUnit
    end

  | ExprMatch em ->
    let* scrut_val = eval env em.em_scrutinee in
    eval_match_arms env scrut_val em.em_arms

  | ExprLambda lam ->
    Ok (VClosure {
      cl_params = lam.elam_params;
      cl_body = lam.elam_body;
      cl_env = env;
    })

  | ExprApp (func, args) ->
    let* func_val = eval env func in
    let* arg_vals = eval_list env args in
    apply_function func_val arg_vals

  | ExprStringConcat (left, right) ->
    (* String-wall slice 8b: the interpreter is the oracle and never sees the
       wasm-only elaboration, but handle it defensively as ordinary String
       `++` so the node has identical semantics in every backend. *)
    eval env (ExprBinary (left, OpConcat, right))

  | ExprStringEq (left, right, negate) ->
    (* String-wall slice 9: as with ExprStringConcat, the interpreter is the
       oracle and never sees the wasm-only elaboration; handle it defensively
       as the original `==`/`!=` so semantics match across every backend. *)
    eval env (ExprBinary (left, (if negate then OpNe else OpEq), right))

  | ExprStringRel (left, right, op) ->
    (* String-wall slice 10: defensively re-dispatch to the original
       relational `ExprBinary` — the interpreter compares strings directly and
       never sees this wasm-only elaboration. *)
    eval env (ExprBinary (left, op, right))

  | ExprFloatBinary (left, op, right) ->
    (* Float wall: re-dispatch to the original Float `ExprBinary` — the
       interpreter evaluates float ops directly and never sees this wasm-only
       elaboration. *)
    eval env (ExprBinary (left, op, right))

  | ExprFloatArray elements ->
    (* Float heap wall: re-dispatch to the ordinary array — [VArray] holds boxed
       float values, with no wasm cell model to mismodel. *)
    eval env (ExprArray elements)

  | ExprFloatIndex (arr, idx) ->
    (* Float heap wall: re-dispatch to the ordinary index. *)
    eval env (ExprIndex (arr, idx))

  | ExprCellTuple cells ->
    (* Float heap wall: re-dispatch to the ordinary tuple (drop cell kinds). *)
    eval env (ExprTuple (List.map fst cells))

  | ExprCellTupleIndex (tup, i, _) ->
    (* Float heap wall: re-dispatch to the ordinary tuple index. *)
    eval env (ExprTupleIndex (tup, i))

  | ExprCellRecord fields ->
    (* Float heap wall: re-dispatch to the ordinary record (drop cell kinds). *)
    eval env (ExprRecord { er_fields = List.map (fun (id, e, _) -> (id, Some e)) fields;
                           er_spread = None })

  | ExprCellField (rec_e, _, _) ->
    (* Float heap wall: re-dispatch — but the interpreter needs the field NAME,
       which this wasm-only node has dropped in favour of a byte offset. The
       interpreter never sees this node in practice (it evaluates the pre-
       elaboration tree); fail loudly if that assumption is ever violated. *)
    ignore rec_e;
    Error (RuntimeError "ExprCellField is a wasm-only elaboration; the interpreter \
                         evaluates the pre-elaboration ExprField")

  | ExprBinary (left, op, right) ->
    let* left_val = eval env left in
    let* right_val = eval env right in
    eval_binop op left_val right_val

  | ExprUnary (op, operand) ->
    let* operand_val = eval env operand in
    unary_op op operand_val

  | ExprTuple exprs ->
    let* vals = eval_list env exprs in
    Ok (VTuple vals)

  | ExprArray exprs ->
    let* vals = eval_list env exprs in
    Ok (VArray (Array.of_list vals))

  | ExprRecord er ->
    (* Start with spread base if present *)
    let* base_fields = match er.er_spread with
      | Some spread_expr ->
        let* spread_val = eval env spread_expr in
        begin match spread_val with
          | VRecord fields -> Ok fields
          | _ -> Error (TypeMismatch "Spread operator requires a record")
        end
      | None -> Ok []
    in
    let* field_vals = List.fold_right (fun (id, expr_opt) acc ->
      let* fields = acc in
      match expr_opt with
      | Some e ->
        let* v = eval env e in
        Ok ((id.name, v) :: fields)
      | None ->
        (* Punning: {x} is short for {x: x} *)
        let* v = lookup_env id.name env in
        Ok ((id.name, v) :: fields)
    ) er.er_fields (Ok []) in
    (* Merge: explicit fields override spread fields *)
    let explicit_names = List.map fst field_vals in
    let remaining_base = List.filter (fun (n, _) ->
      not (List.mem n explicit_names)
    ) base_fields in
    Ok (VRecord (field_vals @ remaining_base))

  | ExprField (base, field) ->
    let* base_val = eval env base in
    begin match base_val with
      | VRecord fields -> get_field field.name fields
      | _ -> Error (TypeMismatch "Expected record")
    end

  | ExprTupleIndex (base, idx) ->
    let* base_val = eval env base in
    begin match base_val with
      | VTuple elems -> get_tuple_elem idx elems
      | _ -> Error (TypeMismatch "Expected tuple")
    end

  | ExprIndex (arr, idx_expr) ->
    let* arr_val = eval env arr in
    let* idx_val = eval env idx_expr in
    begin match (arr_val, idx_val) with
      | (VArray arr, VInt idx) -> get_array_elem idx arr
      | (VArray _, _) -> Error (TypeMismatch "Array index must be integer")
      | _ -> Error (TypeMismatch "Expected array")
    end

  | ExprBlock blk ->
    eval_block env blk

  | ExprReturn e_opt ->
    begin match e_opt with
      | Some e -> eval env e
      | None -> Ok VUnit
    end

  | ExprVariant (type_id, variant_id) ->
    (* Type::Variant syntax - just the variant constructor without payload *)
    let _ = type_id in  (* Ignore type part for now *)
    Ok (VVariant (variant_id.name, None))

  | ExprRowRestrict (base, field) ->
    let* base_val = eval env base in
    begin match base_val with
      | VRecord fields ->
        let filtered = List.filter (fun (n, _) -> n <> field.name) fields in
        Ok (VRecord filtered)
      | _ -> Error (TypeMismatch "Row restriction requires a record")
    end

  | ExprHandle eh ->
    (* Evaluate the body expression. If it performs an effect via
       PerformEffect, we match against the handler arms.
       HandlerReturn arms match the normal return value.
       HandlerOp arms match performed effects. *)
    begin match eval env eh.eh_body with
      | Ok v ->
        (* Normal return — look for a HandlerReturn arm *)
        let return_arm = List.find_opt (fun arm ->
          match arm with HandlerReturn _ -> true | _ -> false
        ) eh.eh_handlers in
        begin match return_arm with
          | Some (HandlerReturn (pat, body)) ->
            let* bindings = match_pattern pat v in
            let env' = extend_env_list bindings env in
            eval env' body
          | _ -> Ok v  (* No return handler — pass through *)
        end
      | Error (PerformEffect (op_name, args)) ->
        (* Effect performed — find matching HandlerOp arm *)
        let op_arm = List.find_opt (fun arm ->
          match arm with
          | HandlerOp (id, _, _) -> id.name = op_name
          | _ -> false
        ) eh.eh_handlers in
        begin match op_arm with
          | Some (HandlerOp (_, pats, body)) ->
            (* Build the resume continuation.  In this tree-walking interpreter
               the continuation is shallow: calling resume(v) returns v as the
               result of the entire `handle` expression.  This is correct for
               the common single-shot, tail-resume pattern.  Full multi-shot
               continuations require either OCaml 5 effects or a CPS transform. *)
            (* #555: the shallow continuation is sound only for single-shot
               tail-resume.  Multi-shot resume (calling `resume` more than
               once) cannot be expressed without reified continuations and
               previously produced a silently-wrong value — each call merely
               returned its argument, so e.g. `resume(1) + resume(2)` yielded
               `3` instead of running the continuation twice.  Count
               invocations and fail loudly on the second call so a multi-shot
               handler can never silently miscompute.  (Non-tail single-shot
               resume — `let x = op(); x + 100` resuming to `5` rather than
               `105` — remains a documented shallow-resume incompleteness: the
               body has already unwound the bind chain, so the discarded
               continuation is undetectable here without a CPS transform.) *)
            let resume_count = ref 0 in
            let resume_fn = VBuiltin ("__resume__", fun resume_args ->
              incr resume_count;
              if !resume_count > 1 then
                Error (RuntimeError
                  ("multi-shot resume is not supported by the tree-walking \
                    interpreter: `resume` was called more than once in the \
                    handler for effect `" ^ op_name ^ "` (Refs #555). Only \
                    single-shot tail-resume is implemented; multi-shot \
                    handlers require reified delimited continuations."))
              else
                match resume_args with
                | [v] -> Ok v
                | []  -> Ok VUnit
                | vs  -> Ok (VTuple vs)
            ) in
            (* Bind effect argument values to handler patterns.
               Convention: all declared params first, then the continuation as
               the last pattern.  Pass args flat (not wrapped in a tuple) so
               that multi-arg effects bind correctly to separate patterns. *)
            let all_vals = args @ [resume_fn] in
            let n_pats = List.length pats in
            let n_vals = List.length all_vals in
            (* If the handler omits the continuation param, provide it anyway
               so that ExprResume still works via the __resume__ env slot. *)
            let trimmed_vals = List.filteri (fun i _ -> i < n_pats) all_vals in
            let pad_vals =
              if n_vals < n_pats then
                trimmed_vals @ List.init (n_pats - n_vals) (fun _ -> VUnit)
              else trimmed_vals
            in
            let bindings = List.fold_left2 (fun acc pat v ->
              match acc with
              | Ok bs ->
                begin match match_pattern pat v with
                  | Ok new_bs -> Ok (new_bs @ bs)
                  | Error e -> Error e
                end
              | Error e -> Error e
            ) (Ok []) pats pad_vals in
            let* bindings = bindings in
            (* Also bind the resume fn under "__resume__" so that the
               `ExprResume` keyword form can find it regardless of what
               name the programmer chose for the continuation parameter. *)
            let env' =
              extend_env "__resume__" resume_fn
                (extend_env_list bindings env)
            in
            eval env' body
          | _ -> Error (RuntimeError ("Unhandled effect: " ^ op_name))
        end
      | Error e -> Error e
    end

  | ExprResume arg_opt ->
    (* Evaluate the argument, then call the resume continuation bound in the
       environment by the enclosing ExprHandle dispatcher.  The continuation
       is stored under "__resume__" so that the `resume expr` keyword form
       works without the programmer having to name the continuation parameter.
       If called outside a handler (no "__resume__" in env), return the value
       as-is — this matches the surface-syntax intuition "resume x ≈ x". *)
    let* arg_val = match arg_opt with
      | Some e -> eval env e
      | None   -> Ok VUnit
    in
    begin match lookup_env "__resume__" env with
      | Ok resume_fn -> apply_function resume_fn [arg_val]
      | Error _      -> Ok arg_val
    end

  | ExprTry et ->
    (* Evaluate the body block. If it returns an error, match against
       catch arms. Always run finally block if present. *)
    let body_result = eval_block env et.et_body in
    let catch_result = match body_result with
      | Ok v -> Ok v
      | Error (RuntimeError msg) ->
        begin match et.et_catch with
          | Some arms ->
            (* Wrap the error as a variant for pattern matching *)
            let err_val = VVariant ("RuntimeError", Some (VString msg)) in
            eval_match_arms env err_val arms
          | None -> Error (RuntimeError msg)
        end
      | Error (PatternMatchFailure) ->
        begin match et.et_catch with
          | Some arms ->
            let err_val = VVariant ("PatternMatchFailure", None) in
            eval_match_arms env err_val arms
          | None -> Error PatternMatchFailure
        end
      | Error e -> Error e
    in
    (* Run finally block if present (result is discarded) *)
    begin match et.et_finally with
      | Some finally_blk ->
        let _ = eval_block env finally_blk in
        catch_result
      | None -> catch_result
    end

  | ExprUnsafe ops ->
    (* Evaluate unsafe operations - for now, just evaluate contained expressions *)
    begin match ops with
      | [] -> Ok VUnit
      | [UnsafeRead e] -> eval env e
      | [UnsafeWrite (ptr, value)] ->
        let* _ptr_val = eval env ptr in
        let* _val = eval env value in
        Ok VUnit
      | [UnsafeOffset (base, offset)] ->
        let* _base = eval env base in
        let* _offset = eval env offset in
        Ok VUnit
      | [UnsafeTransmute (_, _, e)] -> eval env e
      | [UnsafeForget e] ->
        let* _ = eval env e in
        Ok VUnit
      | _ -> Error (RuntimeError "Multiple unsafe operations not yet supported")
    end

  | ExprSpan (e, _) ->
    eval env e

(** Evaluate a list of expressions strictly left-to-right.

    Per ADR-003, all n-ary expression forms (application arguments, tuple
    components, array elements, record fields) evaluate their subexpressions
    in source order. The previous implementation used [List.fold_right] with
    monadic bind, which under OCaml's strict evaluation visited elements
    right-to-left — inconsistent with [ExprBinary] and a latent divergence
    point for future affine enforcement and effect handlers. *)
and eval_list (env : env) (exprs : expr list) : value list result =
  let rec loop acc = function
    | [] -> Ok (List.rev acc)
    | expr :: rest ->
      let* v = eval env expr in
      loop (v :: acc) rest
  in
  loop [] exprs

(** Evaluate match arms *)
and eval_match_arms (env : env) (scrut_val : value) (arms : match_arm list) : value result =
  match arms with
  | [] -> Error PatternMatchFailure
  | arm :: rest ->
    begin match match_pattern arm.ma_pat scrut_val with
      | Ok bindings ->
        let env' = extend_env_list bindings env in
        (* Check guard if present *)
        begin match arm.ma_guard with
          | Some guard ->
            let* guard_val = eval env' guard in
            if is_truthy guard_val then
              eval env' arm.ma_body
            else
              eval_match_arms env scrut_val rest
          | None ->
            eval env' arm.ma_body
        end
      | Error _ ->
        eval_match_arms env scrut_val rest
    end

(** Evaluate a block *)
and eval_block (env : env) (blk : block) : value result =
  let* env' = eval_stmts env blk.blk_stmts in
  match blk.blk_expr with
  | Some e -> eval env' e
  | None -> Ok VUnit

(** Evaluate statements, returning updated environment *)
and eval_stmts (env : env) (stmts : stmt list) : env result =
  List.fold_left (fun acc stmt ->
    let* env = acc in
    eval_stmt env stmt
  ) (Ok env) stmts

(** Evaluate a statement *)
and eval_stmt (env : env) (stmt : stmt) : env result =
  match stmt with
  | StmtLet sl ->
    let* rhs_val = eval env sl.sl_value in
    let* bindings = match_pattern sl.sl_pat rhs_val in
    Ok (extend_env_list bindings env)

  | StmtExpr e ->
    let* _ = eval env e in
    Ok env

  | StmtAssign (lhs, _op, rhs) ->
    let* lhs_val = eval env lhs in
    let* rhs_val = eval env rhs in
    let* () = assign lhs_val rhs_val in
    Ok env

  | StmtWhile (cond, body) ->
    eval_while env cond body

  | StmtFor (pat, iter, body) ->
    let* iter_val = eval env iter in
    eval_for env pat iter_val body

(** Evaluate while loop *)
and eval_while (env : env) (cond : expr) (body : block) : env result =
  let* cond_val = eval env cond in
  if is_truthy cond_val then
    let* _ = eval_block env body in
    eval_while env cond body
  else
    Ok env

(** Evaluate for loop *)
and eval_for (env : env) (pat : pattern) (iter : value) (body : block) : env result =
  match iter with
  | VArray arr ->
    Array.fold_left (fun acc elem ->
      let* env = acc in
      let* bindings = match_pattern pat elem in
      let env' = extend_env_list bindings env in
      let* _ = eval_block env' body in
      Ok env
    ) (Ok env) arr
  | _ -> Error (TypeMismatch "Expected iterable")

(** Evaluate binary operation *)
and eval_binop (op : binary_op) (left : value) (right : value) : value result =
  match (left, right) with
  | (VInt a, VInt b) -> binop_int op a b
  | (VFloat a, VFloat b) -> binop_float op a b
  | (VString a, VString b) -> binop_string op a b
  | (VBool a, VBool b) -> binop_bool op a b
  | _ -> Error (TypeMismatch "Type mismatch in binary operation")

(** Apply function to arguments *)
and apply_function (func : value) (args : value list) : value result =
  match func with
  | VClosure cl ->
    if List.length args <> List.length cl.cl_params then
      Error (TypeMismatch "Argument count mismatch")
    else
      let bindings = List.map2 (fun param arg ->
        (param.p_name.name, arg)
      ) cl.cl_params args in
      let env' = extend_env_list bindings cl.cl_env in
      eval env' cl.cl_body

  | VBuiltin (_, f) -> f args

  | _ -> Error (TypeMismatch "Expected function")

(** Create initial environment with builtins *)
let create_initial_env () : env =
  let builtins = [
    (* -- Console I/O -------------------------------------------------------- *)
    ("print", VBuiltin ("print", fun args ->
      List.iter (fun v -> print_string (Value.show_value v)) args;
      Ok VUnit
    ));
    ("println", VBuiltin ("println", fun args ->
      List.iter (fun v -> print_endline (Value.show_value v)) args;
      Ok VUnit
    ));
    ("eprint", VBuiltin ("eprint", fun args ->
      List.iter (fun v -> prerr_string (Value.show_value v)) args;
      Ok VUnit
    ));
    ("eprintln", VBuiltin ("eprintln", fun args ->
      List.iter (fun v -> prerr_endline (Value.show_value v)) args;
      Ok VUnit
    ));

    (* -- Collection / string length ---------------------------------------- *)
    ("len", VBuiltin ("len", fun args ->
      match args with
      | [VArray arr] -> Ok (VInt (Array.length arr))
      | [VString s] -> Ok (VInt (String.length s))
      | _ -> Error (TypeMismatch "len expects array or string")
    ));

    (* slice(coll, lo, hi) — issue #135 slice 2. Half-open [lo, hi);
       negative indices count from the end; bounds are clamped (JS .slice
       semantics, matching the Deno-ESM backend lowering). *)
    ("slice", VBuiltin ("slice", fun args ->
      let norm n i = if i < 0 then max 0 (n + i) else min i n in
      match args with
      | [VArray arr; VInt lo; VInt hi] ->
        let n = Array.length arr in
        let lo = norm n lo and hi = norm n hi in
        Ok (VArray (if hi > lo then Array.sub arr lo (hi - lo) else [||]))
      | [VString s; VInt lo; VInt hi] ->
        let n = String.length s in
        let lo = norm n lo and hi = norm n hi in
        Ok (VString (if hi > lo then String.sub s lo (hi - lo) else ""))
      | _ -> Error (TypeMismatch "slice expects (array|string, Int, Int)")
    ));

    (* -- String builtins --------------------------------------------------- *)
    ("string_get", VBuiltin ("string_get", fun args ->
      match args with
      | [VString s; VInt idx] ->
        if idx >= 0 && idx < String.length s then
          Ok (VChar (String.get s idx))
        else
          Error (IndexOutOfBounds (idx, String.length s))
      | _ -> Error (TypeMismatch "string_get expects (String, Int)")
    ));
    ("string_sub", VBuiltin ("string_sub", fun args ->
      match args with
      | [VString s; VInt start; VInt length] ->
        let slen = String.length s in
        let start' = max 0 (min start slen) in
        let length' = max 0 (min length (slen - start')) in
        Ok (VString (String.sub s start' length'))
      | _ -> Error (TypeMismatch "string_sub expects (String, Int, Int)")
    ));
    ("string_find", VBuiltin ("string_find", fun args ->
      match args with
      | [VString haystack; VString needle] ->
        let hlen = String.length haystack in
        let nlen = String.length needle in
        (* Length guards first: an empty needle matches at index 0 (standard),
           and a needle longer than the haystack cannot match. Both must
           precede `String.get needle 0` below, which raises on an empty
           needle — the prior ordering made the nlen=0 branch dead code and
           crashed the interp with an uncaught Invalid_argument. This keeps
           the wasm backend (PHASE-F string-wall) and the interp in agreement. *)
        if nlen = 0 then Ok (VInt 0)
        else if nlen > hlen then Ok (VInt (-1))
        else
          (match String.index_opt haystack (String.get needle 0) with
           | None -> Ok (VInt (-1))
           | Some _ ->
             let found = ref (-1) in
             for i = 0 to hlen - nlen do
               if !found = -1 && String.sub haystack i nlen = needle then
                 found := i
             done;
             Ok (VInt !found))
      | _ -> Error (TypeMismatch "string_find expects (String, String)")
    ));
    ("char_to_int", VBuiltin ("char_to_int", fun args ->
      match args with
      | [VChar c] -> Ok (VInt (Char.code c))
      | _ -> Error (TypeMismatch "char_to_int expects Char")
    ));
    ("int_to_char", VBuiltin ("int_to_char", fun args ->
      match args with
      | [VInt n] ->
        if n >= 0 && n <= 127 then Ok (VChar (Char.chr n))
        else Error (RuntimeError "int_to_char: code point out of ASCII range")
      | _ -> Error (TypeMismatch "int_to_char expects Int")
    ));
    (* Byte-oriented String <-> Int accessors (see typecheck.ml bindings).
       string_char_code_at returns the 0..255 byte at [i]; out-of-bounds
       reads return -1 (mirroring string_find's "absent" sentinel rather
       than raising, so decoders can probe defensively).
       string_from_char_code builds a one-byte string from [n & 0xff]. *)
    ("string_char_code_at", VBuiltin ("string_char_code_at", fun args ->
      match args with
      | [VString s; VInt i] ->
        if i >= 0 && i < String.length s then Ok (VInt (Char.code s.[i]))
        else Ok (VInt (-1))
      | _ -> Error (TypeMismatch "string_char_code_at expects (String, Int)")
    ));
    ("string_from_char_code", VBuiltin ("string_from_char_code", fun args ->
      match args with
      | [VInt n] -> Ok (VString (String.make 1 (Char.chr (n land 0xff))))
      | _ -> Error (TypeMismatch "string_from_char_code expects Int")
    ));
    ("show", VBuiltin ("show", fun args ->
      match args with
      | [v] -> Ok (VString (Value.show_value v))
      | _ -> Error (TypeMismatch "show expects a single argument")
    ));
    ("to_lowercase", VBuiltin ("to_lowercase", fun args ->
      match args with
      | [VString s] -> Ok (VString (String.lowercase_ascii s))
      | _ -> Error (TypeMismatch "to_lowercase expects String")
    ));
    ("to_uppercase", VBuiltin ("to_uppercase", fun args ->
      match args with
      | [VString s] -> Ok (VString (String.uppercase_ascii s))
      | _ -> Error (TypeMismatch "to_uppercase expects String")
    ));
    ("trim", VBuiltin ("trim", fun args ->
      match args with
      | [VString s] -> Ok (VString (String.trim s))
      | _ -> Error (TypeMismatch "trim expects String")
    ));
    ("int_to_string", VBuiltin ("int_to_string", fun args ->
      match args with
      | [VInt n] -> Ok (VString (string_of_int n))
      | _ -> Error (TypeMismatch "int_to_string expects Int")
    ));
    ("float_to_string", VBuiltin ("float_to_string", fun args ->
      match args with
      | [VFloat f] -> Ok (VString (string_of_float f))
      | _ -> Error (TypeMismatch "float_to_string expects Float")
    ));
    (* STDLIB-04e (Refs #332): `string_length : String -> Int / Pure` is
       declared in stdlib/effects.affine, resolved by lib/resolve.ml, and
       typed by lib/typecheck.ml — but the runtime VBuiltin entry was
       missing here. Programs that call `string_length` would compile
       cleanly and fail at run with `Unbound variable: string_length`
       (broke E2E STDLIB-04e #332 + STDLIB-04b #329 — the latter uses
       `string_length(k) > 0` as a guard, so the missing binding masked
       the divergence-vs-RuntimeError assertion as an Unbound variable
       error instead). Wire it as the canonical String.length surface. *)
    ("string_length", VBuiltin ("string_length", fun args ->
      match args with
      | [VString s] -> Ok (VInt (String.length s))
      | _ -> Error (TypeMismatch "string_length expects String")
    ));
    (* STDLIB-04e (Refs #332): `string_to_int` is the typed-alias surface
       declared in stdlib/effects.affine. Same semantics as `parse_int`
       (the canonical name) — the alias was unwired before this PR, so
       any caller of the documented extern would compile and fail at run. *)
    ("string_to_int", VBuiltin ("string_to_int", fun args ->
      match args with
      | [VString s] ->
        (match int_of_string_opt s with
         | Some n -> Ok (VVariant ("Some", Some (VInt n)))
         | None -> Ok (VVariant ("None", None)))
      | _ -> Error (TypeMismatch "string_to_int expects String")
    ));
    ("parse_int", VBuiltin ("parse_int", fun args ->
      match args with
      | [VString s] ->
        (match int_of_string_opt s with
         | Some n -> Ok (VVariant ("Some", Some (VInt n)))
         | None -> Ok (VVariant ("None", None)))
      | _ -> Error (TypeMismatch "parse_int expects String")
    ));
    ("parse_float", VBuiltin ("parse_float", fun args ->
      match args with
      | [VString s] ->
        (match float_of_string_opt s with
         | Some f -> Ok (VVariant ("Some", Some (VFloat f)))
         | None -> Ok (VVariant ("None", None)))
      | _ -> Error (TypeMismatch "parse_float expects String")
    ));

    (* -- Math builtins ----------------------------------------------------- *)
    ("sqrt", VBuiltin ("sqrt", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.sqrt f))
      | _ -> Error (TypeMismatch "sqrt expects Float")
    ));
    ("cbrt", VBuiltin ("cbrt", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.cbrt f))
      | _ -> Error (TypeMismatch "cbrt expects Float")
    ));
    ("pow_float", VBuiltin ("pow_float", fun args ->
      match args with
      | [VFloat base; VFloat exp] -> Ok (VFloat (Float.pow base exp))
      | _ -> Error (TypeMismatch "pow_float expects (Float, Float)")
    ));
    ("floor", VBuiltin ("floor", fun args ->
      match args with
      | [VFloat f] -> Ok (VInt (Float.to_int (Float.floor f)))
      | _ -> Error (TypeMismatch "floor expects Float")
    ));
    ("ceil", VBuiltin ("ceil", fun args ->
      match args with
      | [VFloat f] -> Ok (VInt (Float.to_int (Float.ceil f)))
      | _ -> Error (TypeMismatch "ceil expects Float")
    ));
    ("round", VBuiltin ("round", fun args ->
      match args with
      | [VFloat f] -> Ok (VInt (Float.to_int (Float.round f)))
      | _ -> Error (TypeMismatch "round expects Float")
    ));
    ("trunc", VBuiltin ("trunc", fun args ->
      match args with
      | [VFloat f] -> Ok (VInt (Float.to_int (Float.of_int (Float.to_int f))))
      | _ -> Error (TypeMismatch "trunc expects Float")
    ));
    ("sin", VBuiltin ("sin", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.sin f))
      | _ -> Error (TypeMismatch "sin expects Float")
    ));
    ("cos", VBuiltin ("cos", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.cos f))
      | _ -> Error (TypeMismatch "cos expects Float")
    ));
    ("tan", VBuiltin ("tan", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.tan f))
      | _ -> Error (TypeMismatch "tan expects Float")
    ));
    ("asin", VBuiltin ("asin", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.asin f))
      | _ -> Error (TypeMismatch "asin expects Float")
    ));
    ("acos", VBuiltin ("acos", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.acos f))
      | _ -> Error (TypeMismatch "acos expects Float")
    ));
    ("atan", VBuiltin ("atan", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.atan f))
      | _ -> Error (TypeMismatch "atan expects Float")
    ));
    ("atan2", VBuiltin ("atan2", fun args ->
      match args with
      | [VFloat y; VFloat x] -> Ok (VFloat (Float.atan2 y x))
      | _ -> Error (TypeMismatch "atan2 expects (Float, Float)")
    ));
    ("exp", VBuiltin ("exp", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.exp f))
      | _ -> Error (TypeMismatch "exp expects Float")
    ));
    ("log", VBuiltin ("log", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.log f))
      | _ -> Error (TypeMismatch "log expects Float")
    ));
    ("log10", VBuiltin ("log10", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.log10 f))
      | _ -> Error (TypeMismatch "log10 expects Float")
    ));
    ("log2", VBuiltin ("log2", fun args ->
      match args with
      | [VFloat f] -> Ok (VFloat (Float.log2 f))
      | _ -> Error (TypeMismatch "log2 expects Float")
    ));

    (* -- Mut effect builtins (STDLIB-04a, Refs #328) ----------------------
       Backs the [stdlib/effects.affine] externs `make_ref`/`get`/`set`,
       declared `/ Mut`. Distinct from the borrow-checker [&]/[&mut]
       references: these are runtime mutable cells (parameterised type
       [Ref<T>] in the stdlib). The interp uses [VMut] (an existing
       mutable-cell variant in [Value]) so [get]/[set] go through the
       same deref/assign primitives used by the [&mut]-surface. *)
    ("make_ref", VBuiltin ("make_ref", fun args ->
      match args with
      | [v] -> Ok (VMut (ref v))
      | _ -> Error (TypeMismatch "make_ref expects exactly one argument")
    ));
    ("get", VBuiltin ("get", fun args ->
      match args with
      | [VMut r] | [VRef r] -> Ok !r
      | _ -> Error (TypeMismatch "get expects a Ref<T>")
    ));
    ("set", VBuiltin ("set", fun args ->
      match args with
      | [VMut r; v] -> r := v; Ok VUnit
      | _ -> Error (TypeMismatch "set expects (Ref<T>, T)")
    ));

    (* -- I/O builtins ------------------------------------------------------ *)
    ("panic", VBuiltin ("panic", fun args ->
      match args with
      | [VString msg] -> Error (RuntimeError msg)
      | _ -> Error (RuntimeError "panic!")
    ));
    (* STDLIB-04b (Refs #329): `error<T>(msg)` is panic's polymorphic
       sibling. Same divergent runtime semantics (RuntimeError); the
       polymorphic return type is unobservable because the call never
       returns. Backs the `extern fn error<T>(msg: String) -> T / Throws`
       in stdlib/effects.affine. *)
    ("error", VBuiltin ("error", fun args ->
      match args with
      | [VString msg] -> Error (RuntimeError msg)
      | _ -> Error (RuntimeError "error!")
    ));
    ("read_file", VBuiltin ("read_file", fun args ->
      match args with
      | [VString path] ->
        (try
          let ic = open_in path in
          let n = in_channel_length ic in
          let s = Bytes.create n in
          really_input ic s 0 n;
          close_in ic;
          Ok (VVariant ("Ok", Some (VString (Bytes.to_string s))))
        with
        | Sys_error msg -> Ok (VVariant ("Err", Some (VString msg))))
      | _ -> Error (TypeMismatch "read_file expects String")
    ));
    ("write_file", VBuiltin ("write_file", fun args ->
      match args with
      | [VString path; VString content] ->
        (try
          let oc = open_out path in
          output_string oc content;
          close_out oc;
          Ok (VVariant ("Ok", Some VUnit))
        with
        | Sys_error msg -> Ok (VVariant ("Err", Some (VString msg))))
      | _ -> Error (TypeMismatch "write_file expects (String, String)")
    ));
    ("append_file", VBuiltin ("append_file", fun args ->
      match args with
      | [VString path; VString content] ->
        (try
          let oc = open_out_gen [Open_append; Open_creat] 0o644 path in
          output_string oc content;
          close_out oc;
          Ok (VVariant ("Ok", Some VUnit))
        with
        | Sys_error msg -> Ok (VVariant ("Err", Some (VString msg))))
      | _ -> Error (TypeMismatch "append_file expects (String, String)")
    ));
    ("file_exists", VBuiltin ("file_exists", fun args ->
      match args with
      | [VString path] -> Ok (VBool (Sys.file_exists path))
      | _ -> Error (TypeMismatch "file_exists expects String")
    ));
    ("is_directory", VBuiltin ("is_directory", fun args ->
      match args with
      | [VString path] -> Ok (VBool (Sys.is_directory path))
      | _ -> Error (TypeMismatch "is_directory expects String")
    ));
    ("getenv", VBuiltin ("getenv", fun args ->
      match args with
      | [VString name] ->
        (match Sys.getenv_opt name with
         | Some v -> Ok (VVariant ("Some", Some (VString v)))
         | None -> Ok (VVariant ("None", None)))
      | _ -> Error (TypeMismatch "getenv expects String")
    ));
    ("getcwd", VBuiltin ("getcwd", fun args ->
      match args with
      | [] -> Ok (VVariant ("Ok", Some (VString (Sys.getcwd ()))))
      | _ -> Error (TypeMismatch "getcwd expects no arguments")
    ));
    ("read_line", VBuiltin ("read_line", fun args ->
      match args with
      | [] ->
        (try Ok (VVariant ("Ok", Some (VString (read_line ()))))
         with End_of_file -> Ok (VVariant ("Err", Some (VString "End of input"))))
      | _ -> Error (TypeMismatch "read_line expects no arguments")
    ));
    ("exit", VBuiltin ("exit", fun args ->
      match args with
      | [VInt code] -> exit code
      | _ -> Error (TypeMismatch "exit expects Int")
    ));

    (* -- Directory operations ------------------------------------------------ *)
    ("list_dir", VBuiltin ("list_dir", fun args ->
      match args with
      | [VString path] ->
        (try
          let handle = Unix.opendir path in
          let entries = ref [] in
          (try while true do
            let entry = Unix.readdir handle in
            if entry <> "." && entry <> ".." then
              entries := entry :: !entries
          done with End_of_file -> ());
          Unix.closedir handle;
          Ok (VVariant ("Ok", Some (VArray (Array.of_list
            (List.rev_map (fun s -> VString s) !entries)))))
        with
        | Unix.Unix_error (_, _, msg) ->
          Ok (VVariant ("Err", Some (VString ("list_dir: " ^ msg))))
        | Sys_error msg ->
          Ok (VVariant ("Err", Some (VString msg))))
      | _ -> Error (TypeMismatch "list_dir expects String")
    ));
    ("create_dir", VBuiltin ("create_dir", fun args ->
      match args with
      | [VString path] ->
        (try
          Unix.mkdir path 0o755;
          Ok (VVariant ("Ok", Some VUnit))
        with
        | Unix.Unix_error (_, _, msg) ->
          Ok (VVariant ("Err", Some (VString ("create_dir: " ^ msg))))
        | Sys_error msg ->
          Ok (VVariant ("Err", Some (VString msg))))
      | _ -> Error (TypeMismatch "create_dir expects String")
    ));
    ("remove_dir", VBuiltin ("remove_dir", fun args ->
      match args with
      | [VString path] ->
        (try
          Unix.rmdir path;
          Ok (VVariant ("Ok", Some VUnit))
        with
        | Unix.Unix_error (_, _, msg) ->
          Ok (VVariant ("Err", Some (VString ("remove_dir: " ^ msg))))
        | Sys_error msg ->
          Ok (VVariant ("Err", Some (VString msg))))
      | _ -> Error (TypeMismatch "remove_dir expects String")
    ));
    ("setenv", VBuiltin ("setenv", fun args ->
      match args with
      | [VString name; VString value] ->
        (try
          Unix.putenv name value;
          Ok (VVariant ("Ok", Some VUnit))
        with
        | Unix.Unix_error (_, _, msg) ->
          Ok (VVariant ("Err", Some (VString ("setenv: " ^ msg)))))
      | _ -> Error (TypeMismatch "setenv expects (String, String)")
    ));
    ("chdir", VBuiltin ("chdir", fun args ->
      match args with
      | [VString path] ->
        (try
          Unix.chdir path;
          Ok (VVariant ("Ok", Some VUnit))
        with
        | Unix.Unix_error (_, _, msg) ->
          Ok (VVariant ("Err", Some (VString ("chdir: " ^ msg))))
        | Sys_error msg ->
          Ok (VVariant ("Err", Some (VString msg))))
      | _ -> Error (TypeMismatch "chdir expects String")
    ));

    (* -- Time --------------------------------------------------------------- *)
    ("time_now", VBuiltin ("time_now", fun _args ->
      Ok (VFloat (Sys.time ()))
    ));

    (* -- Cmd Msg — linear side-effect obligations (Stage 11) --------------- *)
    (* cmd_none : Cmd 'msg — the no-op command; the interpreter represents
       it as VUnit.  At runtime, the TEA loop discards the Cmd after
       extracting the new model from the (model, cmd) pair.
       Linearity is enforced at compile time (quantity checker) not runtime. *)
    ("cmd_none", VUnit);
    (* cmd_perform : (() ->{IO} unit) -> Cmd 'msg — wraps an IO thunk.
       In the interpreter, the Cmd is executed eagerly when constructed.
       In a real browser runtime the thunk would be scheduled by the
       runtime after the update cycle completes. *)
    ("cmd_perform", VBuiltin ("cmd_perform", fun args ->
      match args with
      | [VClosure _ as f] ->
        (* Execute the IO thunk immediately in the interpreter *)
        let* _ = apply_function f [VUnit] in
        Ok VUnit
      | [VBuiltin _ as f] ->
        let* _ = apply_function f [VUnit] in
        Ok VUnit
      | _ ->
        Error (RuntimeError "cmd_perform: expected a zero-argument function")
    ));
    (* -- TEA (The Elm Architecture) interpreter runtime -------------------- *)
    ("tea_run", VBuiltin ("tea_run", fun args ->
      (* tea_run expects a record with fields: init, update, view, subscriptions.
         - init        : () -> (Model, [Cmd])
         - update      : Msg -> Model -> (Model, [Cmd])
         - view        : Model -> Html    (Html is rendered as a string or shown)
         - subscriptions: Model -> [Sub]  (unused at interpreter level)

         The interpreter loop:
           1. Call init() to get the initial model.
           2. Render and print the initial view.
           3. Read lines from stdin; each line becomes a variant Msg.
           4. Call update(msg, model) -> (new_model, cmds).
           5. Print new view. Repeat until EOF. *)
      match args with
      | [VRecord fields] ->
        let get f = match List.assoc_opt f fields with
          | Some v -> Ok v
          | None -> Error (RuntimeError (Printf.sprintf "tea_run: missing field '%s'" f))
        in
        let render_html v =
          let s = match v with
            | VString s -> s
            | VVariant ("Text", Some (VString s)) -> s
            | VVariant ("Node", _) -> "[Html node]"
            | other -> show_value other
          in
          print_endline s
        in
        let* init_fn   = get "init"   in
        let* update_fn = get "update" in
        let* view_fn   = get "view"   in
        (* Call init() -> (model, cmds) — 0-param function, no args *)
        let* init_result = apply_function init_fn [] in
        let model0 = match init_result with
          | VTuple (m :: _) -> m
          | m -> m
        in
        (* Render initial view *)
        let* view0 = apply_function view_fn [model0] in
        render_html view0;
        (* Read-eval-print loop: stdin lines become variant Msgs until EOF *)
        let rec loop model =
          let input = try Some (read_line ()) with End_of_file -> None in
          match input with
          | None -> Ok VUnit  (* EOF — done, clean exit *)
          | Some "" -> loop model  (* blank line — skip *)
          | Some line ->
            let msg = VVariant (String.trim line, None) in
            let* upd_result = apply_function update_fn [msg; model] in
            let new_model = match upd_result with
              | VTuple (m :: _) -> m
              | m -> m
            in
            let* new_view = apply_function view_fn [new_model] in
            render_html new_view;
            loop new_model
        in
        loop model0
      | _ ->
        Error (RuntimeError
          "tea_run expects a record: {init, update, view, subscriptions}")
    ));
  ] in
  builtins

(** Evaluate a top-level declaration *)
let eval_decl (env : env) (decl : top_level) : env result =
  match decl with
  | TopFn fd ->
    (match fd.fd_body with
     | FnExtern ->
       (* Externs have no AST body to evaluate. Their runtime binding is
          provided by [create_initial_env]'s builtin table (panic, error,
          make_ref, …). Skip here so an inline `extern fn` declaration in
          a test source (e.g. the STDLIB-04a Mut round-trip tests) doesn't
          blow up the [FnBlock|FnExpr] match below.
          Refs #328 root-cause for the interp pattern-match-failure. *)
       Ok env
     | FnBlock _ | FnExpr _ ->
       let closure = VClosure {
         cl_params = fd.fd_params;
         cl_body = (match fd.fd_body with
           | FnBlock blk -> ExprBlock blk
           | FnExpr e -> e
           | FnExtern -> assert false (* unreachable: outer match guards *));
         cl_env = env;
       } in
       Ok (extend_env fd.fd_name.name closure env))

  | TopConst tc ->
    let* v = eval env tc.tc_value in
    Ok (extend_env tc.tc_name.name v env)

  | TopType td ->
    (* Register enum constructors so they can be used as values / constructor functions.
       Nullary constructors become VVariant values.
       N-ary constructors become VBuiltin constructor functions. *)
    begin match td.td_body with
      | TyEnum variants ->
        let env' = List.fold_left (fun env (vd : variant_decl) ->
          let name = vd.vd_name.name in
          match vd.vd_fields with
          | [] ->
            (* Nullary constructor: bind directly as a VVariant value *)
            extend_env name (VVariant (name, None)) env
          | [_] ->
            (* Single-payload constructor: wrap arg in VVariant *)
            extend_env name
              (VBuiltin (name, fun args ->
                match args with
                | [v] -> Ok (VVariant (name, Some v))
                | _ -> Error (TypeMismatch (Printf.sprintf "%s expects 1 argument" name))))
              env
          | fields ->
            (* Multi-payload constructor: pack args into a VTuple *)
            let n = List.length fields in
            extend_env name
              (VBuiltin (name, fun args ->
                if List.length args = n then
                  Ok (VVariant (name, Some (VTuple args)))
                else
                  Error (TypeMismatch
                    (Printf.sprintf "%s expects %d arguments" name n))))
              env
        ) env variants in
        Ok env'
      | _ ->
        (* Struct, alias, and other type declarations don't create runtime bindings *)
        Ok env
    end

  | TopTrait _ | TopImpl _ ->
    (* Trait and impl declarations don't affect the runtime value environment *)
    Ok env

  | TopEffect ed ->
    (* Register each effect operation as a PerformEffect-raising builtin.
       When an effect op is called from within a `handle` expression, the
       Error(PerformEffect ...) propagates up the call stack until caught by
       the ExprHandle dispatcher.  Unhandled effects surface as RuntimeError. *)
    let env' = List.fold_left (fun env (op : effect_op_decl) ->
      let op_name = op.eod_name.name in
      let builtin = VBuiltin (op_name, fun args ->
        Error (PerformEffect (op_name, args))
      ) in
      extend_env op_name builtin env
    ) env ed.ed_ops in
    Ok env'

(** Evaluate a program *)
let eval_program (prog : program) : env result =
  let initial_env = create_initial_env () in
  List.fold_left (fun acc decl ->
    let* env = acc in
    eval_decl env decl
  ) (Ok initial_env) prog.prog_decls
