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
This commit is contained in:
parent
dbcba252bf
commit
71bc70d3bc
1 changed files with 68 additions and 104 deletions
174
eval.ml
174
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
|
||||
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
|
||||
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
|
||||
in
|
||||
aux tp
|
||||
f args
|
||||
end
|
||||
|
||||
let rec binop op l r =
|
||||
let find_operator op ts =
|
||||
let filter t =
|
||||
List.filter (fun (ts, _) ->
|
||||
match ts with [] -> false | x::_ -> t=x)
|
||||
in
|
||||
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 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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue