From 8c40e99241a6c3c4b97cd8724d4ad05330beed00 Mon Sep 17 00:00:00 2001
From: Hyeonung Baek <wiserlix@gmail.com>
Date: Sun, 20 Feb 2022 03:35:11 +0900
Subject: [PATCH] Change get/set precedence/associativity to external function

---
 ast.ml    | 16 ----------------
 eval.ml   | 57 ++++++++++++++++++++++++++++++++++++++-----------------
 main.ml   |  2 ++
 parser.ml | 30 +----------------------------
 4 files changed, 43 insertions(+), 62 deletions(-)

diff --git a/ast.ml b/ast.ml
index 193b24c..6a764c2 100644
--- a/ast.ml
+++ b/ast.ml
@@ -15,11 +15,6 @@ type t =
   | Binop of t * operator * t
   | If of t * t * t (* cond then else *)
   | Apply of t * t list (* function application *)
-  (* these will be seperated into external functions. *)
-  | Set_binop_pre of operator * t
-  | Get_binop_pre of operator
-  | Set_binop_aso of operator * string
-  | Get_binop_aso of operator
 
 and operator =
   | Add | Sub | Mul | Div (* arithmetics *)
@@ -89,16 +84,5 @@ let print ast =
       pr "(if"; f co; f th; f el; pr ")"
     | Apply (f, args) ->
       pr "("; aux f; List.iter (fun a -> pr " "; aux a) args; pr ")"
-
-    | Set_binop_pre (op, pre) ->
-      pr "(set_pre %s " (op_to_string op);
-      aux pre;
-      pr ")"
-    | Get_binop_pre op ->
-      pr "(get_pre %s)" (op_to_string op)
-    | Set_binop_aso (op, aso) ->
-      pr "(set_assoc %s %s)" (op_to_string op) aso
-    | Get_binop_aso op ->
-      pr "(get_pre %s)" (op_to_string op)
   in
   aux ast; pr "\n"
diff --git a/eval.ml b/eval.ml
index a6de723..74ede96 100644
--- a/eval.ml
+++ b/eval.ml
@@ -168,6 +168,42 @@ module External = struct
     | [v] -> raise @@ Type.Invalid (Value.typeof v)
     | _ -> invalid_arg "External.floatfun"
 
+  let symbol_to_op op =
+    op
+    |> String.to_seqi
+    |> Lex.find_token
+    |> Option.get
+    |> fst
+    |> Parser.token_to_op
+
+  let set_op_pre = function
+    | [Symbol op; Int l] ->
+      let op = symbol_to_op op in
+      Hashtbl.replace Parser.precedence op l;
+      Nop
+    | _ -> failwith "set_op_pre"
+
+  let get_op_pre = function
+    | [Symbol op] ->
+      let op = symbol_to_op op in
+      Int (Hashtbl.find Parser.precedence op)
+    | _ -> failwith "get_op_pre"
+
+  let set_op_assoc = function
+    | [Symbol op; String a] ->
+      let op = symbol_to_op op in
+      Hashtbl.replace Parser.oper_assoc op @@ Parser.assoc_of_string a;
+      Nop
+    | _ -> failwith "set_op_assoc"
+
+  let get_op_assoc = function
+    | [Symbol op] ->
+      let op = symbol_to_op op in
+      Hashtbl.find_opt Parser.oper_assoc op
+      |> Option.value ~default: Parser.Left_to_right
+      |> (fun a -> String (Parser.assoc_to_string a))
+    | _ -> failwith "get_op_assoc"
+
   let apply f args =
     let f = match f with
       | "sin" -> floatfun Float.sin
@@ -175,6 +211,10 @@ module External = struct
       | "tan" -> floatfun Float.tan
       | "deg" -> floatfun deg
       | "rad" -> floatfun rad
+      | "set_op_pre" -> set_op_pre
+      | "get_op_pre" -> get_op_pre
+      | "set_op_assoc" -> set_op_assoc
+      | "get_op_assoc" -> get_op_assoc
       | _ -> raise @@ Invalid f
     in
     f args
@@ -250,23 +290,6 @@ let rec eval env ast =
       end
     | Apply (v, args) -> apply v args env
 
-    | Set_binop_pre (op, l) ->
-      let l =
-        match aux l with
-        | Int n -> n
-        | v -> raise @@ Type.Invalid (Value.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))
     | _ -> failwith "Eval.eval"
 
 (* apply args to result of expr *)
diff --git a/main.ml b/main.ml
index 2577d39..f3dd1ba 100644
--- a/main.ml
+++ b/main.ml
@@ -27,6 +27,8 @@ let print_error e =
 let stdlib = [
   "sin"; "cos"; "tan";
   "deg"; "rad";
+  "get_op_pre"; "set_op_pre";
+  "get_op_assoc"; "set_op_assoc";
 ]
   |> List.to_seq
   |> Seq.map (fun v -> v, External v)
diff --git a/parser.ml b/parser.ml
index d967970..8e06d4b 100644
--- a/parser.ml
+++ b/parser.ml
@@ -191,11 +191,9 @@ and expr pre seq =
   seq |> oneof [
     ifexpr;
     let_value;
-    oneof [apply; unary; value] @> binop pre;
-    level;
-    assoc;
     lambda;
     extern_value;
+    oneof [apply; unary; value] @> binop pre;
     (* TODO: place error routine here *)
   ]
 
@@ -209,32 +207,6 @@ and let_value seq =
   let f, seq = mustbe (expr min_int) seq in
   Letin (id, e, f), seq
 
-(* level := "level" {"get" | "set"} [op] *)
-and level seq =
-  let _, seq = ident "level" seq in
-  let id, seq = idents (S.of_list ["get"; "set"]) seq in
-  let op, seq = operator seq in
-  if id = "get" then
-    Get_binop_pre op, seq
-  else if id = "set" then
-    let v, seq = value seq in
-    Set_binop_pre (op, v), seq
-  else
-    failwith "Parser.level"
-
-(* assoc := "assoc" {"get" | "set"} [op] *)
-and assoc seq =
-  let _, seq = ident "assoc" seq in
-  let id, seq = idents (S.of_list ["get"; "set"]) seq in
-  let op, seq = operator seq in
-  if id = "get" then
-    Get_binop_aso op, seq
-  else if id = "set" then
-    let a, seq = idents (S.of_list ["left"; "right"]) seq in
-    Set_binop_aso (op, a), seq
-  else
-    failwith "Parser.assoc"
-
 (* lambda := "fun" [ident]+ "->" expr *)
 and lambda seq =
   let _, seq = ident "fun" seq in