From 71bc70d3bc467081552fcde232b7199f13b284b5 Mon Sep 17 00:00:00 2001 From: Hyeonung Baek Date: Sat, 19 Feb 2022 21:46:48 +0900 Subject: [PATCH] Refactor operator system This commit: - removes unused functions - refactors operator overloading & auto-coercion system - changes type signitures of operators - incorperates unary operators into Eval.Operator.operator table - changes external function implementation --- eval.ml | 172 ++++++++++++++++++++++---------------------------------- 1 file changed, 68 insertions(+), 104 deletions(-) diff --git a/eval.ml b/eval.ml index 185354e..f1f48a3 100644 --- a/eval.ml +++ b/eval.ml @@ -100,57 +100,37 @@ module Operator = struct let to_string = Ast.op_to_string let negate = function - | Int n -> Int ~-n - | Float n -> Float ~-.n + | [Int n] -> Int ~-n + | [Float n] -> Float ~-.n | _ -> failwith "Operator.negate" - let vi f a b = - match a, b with - | Int a, Int b -> Int (f a b) + let vi f = function + | [Int a; Int b] -> Int (f a b) | _ -> raise @@ Type.Invalid Int - let vf f a b = - match a, b with - | Float a, Float b -> Float (f a b) + let vf f = function + | [Float a; Float b] -> Float (f a b) | _ -> raise @@ Type.Expected Float - let vb intf floatf a b = - match a, b with - | Int a, Int b -> Bool (intf a b) - | Float a, Float b -> Bool (floatf a b) - | _ -> raise @@ Type.Expected Bool - - let vnot = function - | Bool b -> Bool (not b) - | _ -> raise @@ Type.Expected Bool - - let map ?intf ?floatf ?boolf v = - let app x f = f x in - match v with - | Int i -> Option.map (app i) intf - | Float f -> Option.map (app f) floatf - | Bool b -> Option.map (app b) boolf - | _ -> invalid_arg "Operator.map" - - let eq = vb Int.equal Float.equal - let neq a b = vnot @@ eq a b - - let compare a b = - match a, b with - | Int a, Int b -> Int.compare a b - | Float a, Float b -> Float.compare a b + let compare = function + | [Int a; Int b] -> Int.compare a b + | [Float a; Float b] -> Float.compare a b + | [Bool a; Bool b] -> Bool.compare a b + | [String a; String b] -> String.compare a b + | [Symbol a; Symbol b] -> String.compare a b | _ -> invalid_arg "Operator.compare" - let ge a b = Bool (compare a b >= 0) - let le a b = Bool (compare a b <= 0) - let gt a b = Bool (compare a b > 0) - let lt a b = Bool (compare a b < 0) + let eq vs = Bool (compare vs = 0) + let neq vs = Bool (compare vs <> 0) + let ge vs = Bool (compare vs >= 0) + let le vs = Bool (compare vs <= 0) + let gt vs = Bool (compare vs > 0) + let lt vs = Bool (compare vs < 0) (* operator table *) - (* TODO: refactor operator finding alg (support type vars) *) let operators = let open Type in - let ip = Int, Int and fp = Float, Float 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]; @@ -165,22 +145,13 @@ module Operator = struct LE, any le; GT, any gt; LT, any lt; + Negate, [[Int], negate; [Float], negate]; ] |> 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_unary = function - | Negate -> negate - | op -> raise @@ Unavailable op - - let get_binary op typ = + let get op = Hashtbl.find operators op - |> List.assoc_opt typ end module External = struct @@ -193,60 +164,58 @@ module External = struct d /. 180. *. Float.pi let floatfun f = function - | Float n -> Float (f n) - | v -> raise @@ Type.Invalid (Value.typeof v) + | [Float n] -> Float (f n) + | [v] -> raise @@ Type.Invalid (Value.typeof v) + | _ -> invalid_arg "External.floatfun" let 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 @@ Invalid f + let f = match f with + | "sin" -> floatfun Float.sin + | "cos" -> floatfun Float.cos + | "tan" -> floatfun Float.tan + | "deg" -> floatfun deg + | "rad" -> floatfun rad + | _ -> raise @@ Invalid f + in + f args end -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 - -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 +let find_operator op ts = + let filter t = + List.filter (fun (ts, _) -> + match ts with [] -> false | x::_ -> t=x) in - aux tp + let rec aux ops = function + | [] -> List.nth_opt ops 0 + | t::ts -> + (match aux (filter t ops) ts with + | None -> Option.bind (Type.supertype t) (fun t -> aux ops (t::ts)) + | Some _ as x -> x) + in + aux (Operator.get op) ts -let rec binop op l r = +let promote_values = + let rec promote_until t v = + if Value.typeof v = t + then v + else promote_until t @@ Value.promote v + in + List.map2 promote_until + +let unary op v = + match find_operator op [Value.typeof v] with + | None -> raise No_operation + | Some (ts, f) -> + let vs = promote_values ts [v] in + f vs + +let binop op l r = let open Value in - 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 + match find_operator op [typeof l; typeof r] with + | None -> raise No_operation + | Some (ts, f) -> + let vs = promote_values ts [l; r] in + f vs exception Unbound of string @@ -270,13 +239,8 @@ let rec eval env ast = let env = Env.bind (v, aux e) env in eval env f - | 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 + | Unary (op, v) -> unary op (aux v) + | Binop (l, op, r) -> binop op (aux l) (aux r) | If (co, th, el) -> begin match aux co with | Bool true -> aux th