refactor externals (temp commit)

ast.ml

@@ -16,27 +16,7 @@ type t =
   | If of t * t * t (* cond then else *)
   | Apply of t * t list (* function application *)
 
-and operator =
+and operator = string
-  | Add | Sub | Mul | Div (* arithmetics *)
-  | Mod (* modular operation *)
-  | Exp (* exponentation *)
-  | Eq | Neq | GE | LE | GT | LT
-  | Negate
-
-let op_to_string = function
-  | Add -> "+"
-  | Sub -> "-"
-  | Mul -> "*"
-  | Div -> "/"
-  | Mod -> "%"
-  | Exp -> "^"
-  | Eq -> "="
-  | Neq -> "<>"
-  | GE -> ">="
-  | LE -> "<="
-  | GT -> ">"
-  | LT -> "<"
-  | Negate -> "-"
 
 let unary op t =
   Unary (op, t)
@@ -70,10 +50,8 @@ let print ast =
     | Letin (v, e, f) ->
       pr "(let ((%s " v; aux e; pr ")) "; aux f; pr ")"
     | Unary (op, t) ->
-      let op = op_to_string op in
       pr "(%s " op; aux t; pr ")"
     | Binop (left, op, right) ->
-      let op = op_to_string op in
       pr "(%s " op; aux left; pr " "; aux right; pr ")"
     | If (co, th, el) ->
       let f e = pr " "; aux e in

eval.ml

@@ -17,9 +17,6 @@ and expr = Ast.t
 (* environment for eval *)
 and env = Env of (string * value) list
 
-exception No_operation
-exception Too_many_arguments
-
 (* TODO: add proper type system *)
 module Type = struct
   type t =
@@ -30,6 +27,7 @@ module Type = struct
     | Symbol
     | Function
     | External
+    | Any
 
   exception Invalid of t
   exception Expected of t
@@ -42,10 +40,15 @@ module Type = struct
     | Symbol -> "symbol"
     | Function -> "fun"
     | External -> "external"
+    | Any -> "any"
 
   let supertype = function
     | Int -> Some Float
     | _ -> None
+
+  let matches : t -> t -> bool = function
+    | Any -> Fun.const true
+    | t -> fun o -> o = t || o = Any
 end
 
 module Value = struct
@@ -91,14 +94,8 @@ module Env = struct
     Env (List.of_seq seq @ e)
 end
 
-(* operators *)
+(* primitive methods *)
-module Operator = struct
+module Primitive = struct
-  type t = Ast.operator
-
-  exception Unavailable of t
-
-  let to_string = Ast.op_to_string
-
   let negate = function
     | [Int n] -> Int ~-n
     | [Float n] -> Float ~-.n
@@ -127,45 +124,16 @@ module Operator = struct
   let gt vs = Bool (compare vs > 0)
   let lt vs = Bool (compare vs < 0)
 
-  (* operator table *)
-  let operators =
-    let open Type in
-    let ip = [Int; Int] and fp = [Float; Float] in
-    let any f = [ip, f; fp, f] in
-    [
-      Add, [ip, vi Int.add; fp, vf Float.add];
-      Sub, [ip, vi Int.sub; fp, vf Float.sub];
-      Mul, [ip, vi Int.mul; fp, vf Float.mul];
-      Div, [ip, vi Int.div; fp, vf Float.div];
-      Mod, [ip, vi Int.rem; fp, vf Float.rem];
-      Exp, [fp, vf Float.pow];
-      Eq,  any eq;
-      Neq, any neq;
-      GE, any ge;
-      LE, any le;
-      GT, any gt;
-      LT, any lt;
-      Negate, [[Int], negate; [Float], negate];
-    ]
-    |> List.to_seq
-    |> Hashtbl.of_seq
-
-  let get op =
-    Hashtbl.find operators op
-end
-
-module External = struct
-  exception Invalid of string
-
   let rad r =
     r *. 180. /. Float.pi
 
   let deg d =
     d /. 180. *. Float.pi
 
-  let floatfun f = function
+  let floatfun f =
+    [Type.Float],
+    function
     | [Float n] -> Float (f n)
-    | [v] -> raise @@ Type.Invalid (Value.typeof v)
     | _ -> invalid_arg "External.floatfun"
 
   let symbol_to_op op =
@@ -222,68 +190,103 @@ module External = struct
     Printf.printf "\n";
     Nop
 
-  let apply f args =
+
-    let f = match f with
+  let methods =
-      | "sin" -> floatfun Float.sin
+    let open Type in
-      | "cos" -> floatfun Float.cos
+    let ip = [Int; Int] and fp = [Float; Float] in
-      | "tan" -> floatfun Float.tan
+    let number f = [ip, f; fp, f] in
-      | "deg" -> floatfun deg
+    [
-      | "rad" -> floatfun rad
+      "+", [ip, vi Int.add; fp, vf Float.add];
-      | "set_op_pre" -> set_op_pre
+      "-", [ip, vi Int.sub; fp, vf Float.sub;
-      | "get_op_pre" -> get_op_pre
+            [Int], negate; [Float], negate];
-      | "set_op_assoc" -> set_op_assoc
+      "*", [ip, vi Int.mul; fp, vf Float.mul];
-      | "get_op_assoc" -> get_op_assoc
+      "/", [ip, vi Int.div; fp, vf Float.div];
-      | "print" -> print
+      "%", [ip, vi Int.rem; fp, vf Float.rem];
-      | "println" -> println
+      "^", [fp, vf Float.pow];
-      | _ -> raise @@ Invalid f
+      "=", number eq;
-    in
+      "<>", number neq;
-    f args
+      ">=", number ge;
+      "<=", number le;
+      ">", number gt;
+      "<", number lt;
+
+      "sin", [floatfun Float.sin];
+      "cos", [floatfun Float.cos];
+      "tan", [floatfun Float.tan];
+      "deg", [floatfun deg];
+      "rad", [floatfun rad];
+      "set_op_pre", [[Symbol; Int], set_op_pre];
+      "get_op_pre", [[Symbol], get_op_pre];
+      "set_op_assoc", [[Symbol; String], set_op_assoc];
+      "get_op_assoc", [[Symbol], get_op_assoc];
+      "print", [[Any], print];
+      "println", [[Any], println];
+    ]
+    |> List.to_seq
+    |> Hashtbl.of_seq
+
+  let get op =
+    Hashtbl.find methods op
 end
 
-let find_operator op ts =
+(* find_method returns a method and (corresponding) type list that
+ * satisfies ts. *)
+let find_method m ts =
   let open List in
   let filter_type t i =
     filter (fun (ts, _) ->
         nth_opt ts i
-        |> Option.map ((=) t)
+        |> Option.map (Type.matches t)
         |> Option.value ~default: false)
   in
-  let rec aux ops i = function
+  let rec aux ms i = function
-    | [] ->
+    | [] -> nth_opt ms 0
-      ops
-      |> filter (fun (ts, _) -> length ts = i)
-      |> Fun.flip nth_opt 0
     | t::ts ->
-      (match aux (filter_type t i ops) (i+1) ts with
+      (match aux (filter_type t i ms) (i+1) ts with
        | None -> Option.bind (Type.supertype t)
-                   (fun t -> aux ops i (t::ts))
+                   (fun t -> aux ms i (t::ts))
        | Some _ as x -> x)
   in
-  aux (Operator.get op) 0 ts
+  let ms =
+    let len = length ts in
+    Primitive.get m
+    |> filter (fun (ts, _) -> length ts = len)
+  in
+  aux ms 0 ts
 
 let promote_values =
   let rec promote_until t v =
-    if Value.typeof v = t
+    if Type.matches t @@ Value.typeof v
     then v
     else promote_until t @@ Value.promote v
   in
   List.map2 promote_until
 
+exception No_such_method of string * Type.t
+let no_such m v = raise @@ No_such_method (m, Value.typeof v)
+
 let unary op v =
-  match find_operator op [Value.typeof v] with
+  match find_method op [Value.typeof v] with
-  | None -> raise No_operation
+  | None -> no_such op v
   | Some (ts, f) ->
     let vs = promote_values ts [v] in
     f vs
 
 let binop op l r =
   let open Value in
-  match find_operator op [typeof l; typeof r] with
+  match find_method op [typeof l; typeof r] with
-  | None -> raise No_operation
+  | None -> no_such op l
   | Some (ts, f) ->
     let vs = promote_values ts [l; r] in
     f vs
 
+let extern f args =
+  match find_method f (List.map Value.typeof args) with
+  | None -> no_such f (List.hd args)
+  | Some (ts, f) ->
+    let vs = promote_values ts args in
+    f vs
+
 exception Unbound of string
 
 let rec eval global env ast =
@@ -351,7 +354,7 @@ and apply global env expr args =
         else (* eval (vars = [], args = []) *)
           eval global env body
     end
-  | External f -> External.apply f args
+  | External f -> extern f args
   | v ->
     if args = [] then v
     else raise @@ Type.Invalid (Value.typeof v)

main.ml

@@ -16,7 +16,8 @@ let error_to_string e =
     sprintf "unexpected token \"%s\" at col %d" t col
   | Type.Invalid t -> sprintf "invalid type %s" (Type.to_string t)
   | Eval.Unbound v -> sprintf "unbound value %s" v
-  | Eval.Too_many_arguments -> "applied too many arguments"
+  | Eval.No_such_method (m, t) ->
+    sprintf "no such method %s matching type %s" m (Type.to_string t)
   | Failure f -> sprintf "error on %s" f
   | Division_by_zero -> "cannot divide by zero"
   | _ -> raise e

parser.ml

@@ -19,18 +19,18 @@ let unexpected_token col t =
  * precedency, but infering precedence relation from the graph is hard
  * and the graph can be made to have loops, I just used plain table. *)
 let precedence = [
-  Eq, 1;
+  "=", 1;
-  Neq, 1;
+  "<>", 1;
-  GE, 1;
+  ">=", 1;
-  LE, 1;
+  "<=", 1;
-  GT, 1;
+  ">", 1;
-  LT, 1;
+  "<", 1;
-  Add, 10;
+  "+", 10;
-  Sub, 10;
+  "-", 10;
-  Mul, 20;
+  "*", 20;
-  Div, 20;
+  "/", 20;
-  Mod, 30;
+  "%", 30;
-  Exp, 30;
+  "^", 30;
 ] |> List.to_seq |> Hashtbl.of_seq
 
 let precedence_of op =
@@ -50,7 +50,7 @@ let assoc_to_string = function
   | Right_to_left -> "right"
 
 let oper_assoc = [
-  Exp, Right_to_left;
+  "^", Right_to_left;
 ] |> List.to_seq |> Hashtbl.of_seq
 
 let op_is_right_to_left op =
@@ -61,26 +61,25 @@ let op_is_right_to_left op =
   a = Right_to_left
 
 let operators = [
-  Token.Plus, Add;
+  Token.Plus;
-  Minus, Sub;
+  Minus;
-  Asterisk, Mul;
+  Asterisk;
-  Slash, Div;
+  Slash;
-  Carret, Exp;
+  Carret;
-  Percent, Mod;
+  Percent;
-  Equal, Eq;
+  Equal;
-  Not_equal, Neq;
+  Not_equal;
-  Greater_equal, GE;
+  Greater_equal;
-  Less_equal, LE;
+  Less_equal;
-  Greater, GT;
+  Greater;
-  Less, LT;
+  Less;
-] |> List.to_seq |> Hashtbl.of_seq
+]
 
 let token_to_op tok =
-  try Hashtbl.find operators tok
+  Token.to_string tok
-  with _ -> failwith "Parser.token_to_op"
 
 let token_is_operator tok =
-  Hashtbl.mem operators tok
+  List.mem tok operators
 
 let is_keyword = function
   | "if" | "then" | "else" | "let" | "in" -> true
@@ -250,7 +249,7 @@ and unary seq =
   let op, seq =
     let col, x, seq = any seq in
     if x = Minus
-    then Negate, seq
+    then "-", seq
     else expected col "minus (-)"
   in
   let v, seq = mustbe value seq in