Refactor value

ast.ml

@@ -1,19 +1,53 @@
-type typ =
+module Type = struct
+  type t =
+    | Int
+    | Float
+
+  let to_string = function
+    | Int -> "int"
+    | Float -> "float"
+
+  let merge a b =
+    match a, b with
+    | Int, Float -> Float
+    | Float, Int -> Float
+    | a, b when a = b -> a
+    | _ -> failwith "Type.merge"
+
+end
+
+exception Invalid_type of Type.t
+
+module Value = struct
+  type t =
     | Int of int
     | Float of float
-  | Unit
+    | Nop (* return of system operations *)
 
-let typ_to_string = function
+  let to_string = function
     | Int n -> Printf.sprintf "%d" n
     | Float n -> Printf.sprintf "%f" n
-  | Unit -> "()"
+    | Nop -> "nop"
 
-type binop =
+  let typeof = function
+    | Int _ -> Type.Int
+    | Float _ -> Type.Float
+    | Nop -> failwith "Value.typeof"
+
+  let promote = function
+    | Int n -> Float (float n)
+    | Float n -> Float n
+    | _ -> failwith "Value.promote"
+end
+
+(* binary operator *)
+module Binop = struct
+  type t =
     | Add | Sub | Mul | Div (* arithmetics *)
     | Mod (* modular operation *)
     | Exp (* exponentation *)
 
-let binop_to_string = function
+  let to_string = function
     | Add -> "+"
     | Sub -> "-"
     | Mul -> "*"
@@ -21,38 +55,62 @@ let binop_to_string = function
     | Mod -> "%"
     | Exp -> "^"
 
+  let vi f a b =
+    let open Value in
+    match a, b with
+    | Int a, Int b -> Int (f a b)
+    | _ -> raise @@ Invalid_type Int
+
+  let vf f a b =
+    let open Value in
+    match a, b with
+    | Float a, Float b -> Float (f a b)
+    | _ -> raise @@ Invalid_type Float
+
+  let operators =
+    let open Type in
+    [
+      Add, [Int, vi Int.add; Float, vf Float.add];
+      Sub, [Int, vi Int.sub; Float, vf Float.sub];
+      Mul, [Int, vi Int.mul; Float, vf Float.mul];
+      Div, [Int, vi Int.div; Float, vf Float.div];
+      Mod, [Int, vi Int.rem; Float, vf Float.rem];
+      Exp, [Float, vf Float.pow];
+    ]
+    |> List.to_seq
+    |> Hashtbl.of_seq
+
+  let get op typ =
+    Hashtbl.find operators op
+    |> List.assoc_opt typ
+end
+
 type t =
-  | Value of typ
+  | Value of Value.t
-  | Binop of t * binop * t
+  | Binop of t * Binop.t * t
-  | Set_binop_pre of binop * t
+  | Set_binop_pre of Binop.t * t
-  | Get_binop_pre of binop
+  | Get_binop_pre of Binop.t
 
 let value v = Value v
 
 let binop left op right =
   Binop (left, op, right)
 
-let set_binop_pre op pre =
-  Set_binop_pre (op, pre)
-
 (* print ast LISP style. *)
 let print ast =
   let pr = Printf.printf in
-  let pv v = pr "%s" @@ typ_to_string v in
+  let pv v = pr "%s" @@ Value.to_string v in
   let rec aux = function
     | Value n -> pv n
     | Binop (left, op, right) -> begin
-        pr "(%s " @@ binop_to_string op;
+        let op = Binop.to_string op in
-        aux left;
+        pr "(%s " op; aux left; pr " "; aux right; pr ")";
-        pr " ";
-        aux right;
-        pr ")";
       end
     | Set_binop_pre (op, pre) ->
-      pr "(set_pre %s " (binop_to_string op);
+      pr "(set_pre %s " (Binop.to_string op);
       aux pre;
       pr ")"
     | Get_binop_pre op ->
-      pr "(get_pre %s)" (binop_to_string op)
+      pr "(get_pre %s)" (Binop.to_string op)
   in
   aux ast; pr "\n"

eval.ml

@@ -1,34 +1,37 @@
 open Ast
+open Ast.Value
 
-exception Invalid_type
+exception No_operation
 
-let arith intf floatf a b =
+let rec binop op l r =
-  match a, b with
+  let tl = typeof l and tr = typeof r in
-  | Int a, Int b -> begin
+  let ty = Type.merge tl tr in
-      try Int (intf a b)
+  let rec promote_until t x =
-      with Exit -> Float (floatf (float a) (float b))
+    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
-  | Float a, Int b -> Float (floatf a (float b))
+  | Some f -> f l r
-  | Int a, Float b -> Float (floatf (float a) b)
-  | Float a, Float b -> Float (floatf a b)
-  | _ -> raise Invalid_type
-
-let binop_to_func = function
-  | Add -> arith Int.add Float.add
-  | Sub -> arith Int.sub Float.sub
-  | Mul -> arith Int.mul Float.mul
-  | Div -> arith Int.div Float.div
-  | Mod -> arith Int.rem Float.rem
-  | Exp -> arith (fun _ _ -> raise Exit) Float.pow
 
 let rec eval = function
   | Value v -> v
   | Binop (l, op, r) ->
-    let f = binop_to_func op in
+    let l = eval l and r = eval r in
-    f (eval l) (eval r)
+    binop op l r
   | Set_binop_pre (op, l) ->
-    let l = match eval l with Int n -> n | _ -> raise Invalid_type in
+    let l =
+      match eval l with
+      | Int n -> n
+      | v -> raise @@ Invalid_type (typeof v)
+    in
     Hashtbl.replace Parser.precedence op l;
-    Unit
+    Nop
   | Get_binop_pre op ->
     Int (Hashtbl.find Parser.precedence op)

main.ml

@@ -9,7 +9,7 @@ let error_to_string e =
   | Lex.Token_not_found -> sprintf "invalid token"
   | Parser.Expected t -> sprintf "expected %s" t
   | Parser.Unexpected_token t -> sprintf "unexpected token \"%s\"" t
-  | Eval.Invalid_type -> "invalid type"
+  | Ast.Invalid_type t -> sprintf "invalid type %s" (Ast.Type.to_string t)
   | Failure f -> sprintf "error on %s" f
   | Division_by_zero -> "cannot divide by zero"
   | _ -> raise e
@@ -22,12 +22,15 @@ let rep () : unit =
   printf "> ";
   let line = read_line () in
   if line = "quit" then raise Exit;
+  let ans =
     line
     |> Lex.tokenize
     |> Parser.parse
     |> Eval.eval
-  |> Ast.typ_to_string
+  in
-  |> printf "%s\n"
+  match ans with
+  | Nop -> ()
+  | _ -> printf "%s\n" @@ Ast.Value.to_string ans
 
 let init_repl () =
   let sigintf _ = raise Reset_line in

parser.ml

@@ -1,4 +1,5 @@
 open Ast
+open Ast.Binop
 
 module S = Set.Make(String)
 
@@ -6,7 +7,7 @@ exception Expected of string
 exception Unexpected_token of string
 
 let expected t =
-  raise (Expected t)
+  raise @@ Expected t
 
 let unexpected_token t =
   raise @@ Unexpected_token (Token.to_string t)