ce/eval.ml

open Ast
open Ast.Value

exception No_operation
exception No_such_variable of string

let rec binop op l r =
  let tl = typeof l and tr = typeof r in
  let ty = Type.merge tl tr in
  let rec promote_until t x =
    if typeof x = t
    then x
    else promote_until t (promote x)
  in
  let l = promote_until ty l
  and r = promote_until ty r in
  match Binop.get op ty with
  | None -> begin
      try binop op (promote l) (promote r)
      with _ -> raise No_operation
    end
  | Some f -> f l r

let eval vars ast =
  let rec aux = function
    | Value v -> v
    | Var v -> begin match Hashtbl.find_opt vars v with
        | None -> raise @@ No_such_variable v
        | Some v -> v
      end
    | Unary (op, t) ->
      let t = aux t in
      let op = Unary.get op (Value.typeof t) in
      op t
    | Binop (l, op, r) ->
      let l = aux l and r = aux r in
      binop op l r
    | Let (var, e) ->
      let v = aux e in
      Hashtbl.replace vars var v;
      v
    | Set_binop_pre (op, l) ->
      let l =
        match aux l with
        | Int n -> n
        | v -> raise @@ Invalid_type (typeof v)
      in
      Hashtbl.replace Parser.precedence op l;
      Nop
    | Get_binop_pre op ->
      Int (Hashtbl.find Parser.precedence op)
    | Set_binop_aso (op, a) ->
      Hashtbl.replace Parser.oper_assoc op @@ Parser.assoc_of_string a;
      Nop
    | Get_binop_aso op ->
      match Hashtbl.find_opt Parser.oper_assoc op with
      | None -> String "left"
      | Some a -> String (Parser.assoc_to_string a)
  in
  aux ast