open Ast
open Ast.Value

exception No_operation
exception No_such_variable of string
exception No_such_function of string

exception Too_many_arguments

let assert_same_length vars args =
  let vl = List.length vars
  and al = List.length args in
  if vl > al then
    failwith "assert_same_length"
  else if vl < al then
    raise Too_many_arguments
  else ()

let resolve_type op tp =
  let optypes = Operator.get_types op in
  let q = Queue.create () in
  let rec aux (t1, t2) =
    if List.mem (t1, t2) optypes then
      t1, t2
    else begin
      [ Type.supertype t1 |> Option.map (fun t1 -> t1, t2);
        Type.supertype t2 |> Option.map (fun t2 -> t1, t2); ]
      |> List.filter_map Fun.id
      |> List.iter (Fun.flip Queue.push q);
      aux @@ Queue.pop q
    end
  in
  aux tp

let rec binop op l r =
  let t1 = typeof l and t2 = typeof r in
  let t1, t2 = resolve_type op (t1, t2) in
  let rec promote_until t x =
    if typeof x = t
    then x
    else promote_until t (promote x)
  in
  let l = promote_until t1 l
  and r = promote_until t2 r in
  match Operator.get_binary op (t1, t2) with
  | None -> begin
      try binop op (promote l) (promote r)
      with _ -> raise No_operation
    end
  | Some f -> f l r

let deg r =
  r *. 180. /. Float.pi

let rad d =
  d /. 180. *. Float.pi

let floatfun f = function
  | Float n -> Float (f n)
  | v -> raise @@ Invalid_type (typeof v)

let ex_apply f args =
  match f, args with
  | "sin", [n] -> floatfun Float.sin n
  | "cos", [n] -> floatfun Float.cos n
  | "tan", [n] -> floatfun Float.tan n
  | "deg", [n] -> floatfun deg n
  | "rad", [n] -> floatfun rad n
  | _ -> raise @@ No_such_function f

let rec eval env ast =
  let rec aux = function
    | Value v -> v
    | Var v -> begin match Env.get_opt env v with
        | None -> raise @@ No_such_variable v
        | Some v -> v
      end
    | Unary (op, t) ->
      let t = aux t in
      let op = Operator.get_unary op 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
      Env.set env var v; v
    | Apply (v, args) ->
      begin match aux v with
        | Function (vars, e) ->
          assert_same_length vars args;
          let args = List.map aux args in
          let nenv = Env.make env in
          List.combine vars args
          |> List.iter (fun (v, a) -> Env.set nenv v a);
          eval nenv e
        | External f ->
          let args = List.map aux args in
          ex_apply f args
        | v -> raise @@ Invalid_type (typeof v)
      end
    | 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