Rewrite binop

ast.ml

@@ -9,13 +9,9 @@ module Type = struct
     | Float -> "float"
     | String -> "string"
 
-  let merge a b =
+  let supertype = function
-    match a, b with
+    | Int -> Some Float
-    | Int, Float -> Float
+    | _ -> None
-    | Float, Int -> Float
-    | a, b when a = b -> a
-    | _ -> failwith "Type.merge"
-
 end
 
 exception Invalid_type of Type.t
@@ -71,6 +67,8 @@ module Binop = struct
     | Mod (* modular operation *)
     | Exp (* exponentation *)
 
+  exception Unavailable of t
+
   let to_string = function
     | Add -> "+"
     | Sub -> "-"
@@ -93,17 +91,23 @@ module Binop = struct
 
   let operators =
     let open Type in
+    let ip = Int, Int and fp = Float, Float in
     [
-      Add, [Int, vi Int.add; Float, vf Float.add];
+      Add, [ip, vi Int.add; fp, vf Float.add];
-      Sub, [Int, vi Int.sub; Float, vf Float.sub];
+      Sub, [ip, vi Int.sub; fp, vf Float.sub];
-      Mul, [Int, vi Int.mul; Float, vf Float.mul];
+      Mul, [ip, vi Int.mul; fp, vf Float.mul];
-      Div, [Int, vi Int.div; Float, vf Float.div];
+      Div, [ip, vi Int.div; fp, vf Float.div];
-      Mod, [Int, vi Int.rem; Float, vf Float.rem];
+      Mod, [ip, vi Int.rem; fp, vf Float.rem];
-      Exp, [Float, vf Float.pow];
+      Exp, [fp, vf Float.pow];
     ]
     |> List.to_seq
     |> Hashtbl.of_seq
 
+  let get_types op =
+    match Hashtbl.find_opt operators op with
+    | None -> raise @@ Unavailable op
+    | Some p -> List.map fst p
+
   let get op typ =
     Hashtbl.find operators op
     |> List.assoc_opt typ

eval.ml

@@ -4,17 +4,33 @@ open Ast.Value
 exception No_operation
 exception No_such_variable of string
 
+let resolve_type op tp =
+  let optypes = Binop.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 tl = typeof l and tr = typeof r in
+  let t1 = typeof l and t2 = typeof r in
-  let ty = Type.merge tl tr 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 ty l
+  let l = promote_until t1 l
-  and r = promote_until ty r in
+  and r = promote_until t2 r in
-  match Binop.get op ty with
+  match Binop.get op (t1, t2) with
   | None -> begin
       try binop op (promote l) (promote r)
       with _ -> raise No_operation