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
172
eval.ml
172
eval.ml
|
|
@ -100,57 +100,37 @@ module Operator = struct
|
||||||
let to_string = Ast.op_to_string
|
let to_string = Ast.op_to_string
|
||||||
|
|
||||||
let negate = function
|
let negate = function
|
||||||
| Int n -> Int ~-n
|
| [Int n] -> Int ~-n
|
||||||
| Float n -> Float ~-.n
|
| [Float n] -> Float ~-.n
|
||||||
| _ -> failwith "Operator.negate"
|
| _ -> failwith "Operator.negate"
|
||||||
|
|
||||||
let vi f a b =
|
let vi f = function
|
||||||
match a, b with
|
| [Int a; Int b] -> Int (f a b)
|
||||||
| Int a, Int b -> Int (f a b)
|
|
||||||
| _ -> raise @@ Type.Invalid Int
|
| _ -> raise @@ Type.Invalid Int
|
||||||
|
|
||||||
let vf f a b =
|
let vf f = function
|
||||||
match a, b with
|
| [Float a; Float b] -> Float (f a b)
|
||||||
| Float a, Float b -> Float (f a b)
|
|
||||||
| _ -> raise @@ Type.Expected Float
|
| _ -> raise @@ Type.Expected Float
|
||||||
|
|
||||||
let vb intf floatf a b =
|
let compare = function
|
||||||
match a, b with
|
| [Int a; Int b] -> Int.compare a b
|
||||||
| Int a, Int b -> Bool (intf a b)
|
| [Float a; Float b] -> Float.compare a b
|
||||||
| Float a, Float b -> Bool (floatf a b)
|
| [Bool a; Bool b] -> Bool.compare a b
|
||||||
| _ -> raise @@ Type.Expected Bool
|
| [String a; String b] -> String.compare a b
|
||||||
|
| [Symbol a; Symbol b] -> String.compare a b
|
||||||
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
|
|
||||||
| _ -> invalid_arg "Operator.compare"
|
| _ -> invalid_arg "Operator.compare"
|
||||||
|
|
||||||
let ge a b = Bool (compare a b >= 0)
|
let eq vs = Bool (compare vs = 0)
|
||||||
let le a b = Bool (compare a b <= 0)
|
let neq vs = Bool (compare vs <> 0)
|
||||||
let gt a b = Bool (compare a b > 0)
|
let ge vs = Bool (compare vs >= 0)
|
||||||
let lt a b = Bool (compare a b < 0)
|
let le vs = Bool (compare vs <= 0)
|
||||||
|
let gt vs = Bool (compare vs > 0)
|
||||||
|
let lt vs = Bool (compare vs < 0)
|
||||||
|
|
||||||
(* operator table *)
|
(* operator table *)
|
||||||
(* TODO: refactor operator finding alg (support type vars) *)
|
|
||||||
let operators =
|
let operators =
|
||||||
let open Type in
|
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
|
let any f = [ip, f; fp, f] in
|
||||||
[
|
[
|
||||||
Add, [ip, vi Int.add; fp, vf Float.add];
|
Add, [ip, vi Int.add; fp, vf Float.add];
|
||||||
|
|
@ -165,22 +145,13 @@ module Operator = struct
|
||||||
LE, any le;
|
LE, any le;
|
||||||
GT, any gt;
|
GT, any gt;
|
||||||
LT, any lt;
|
LT, any lt;
|
||||||
|
Negate, [[Int], negate; [Float], negate];
|
||||||
]
|
]
|
||||||
|> List.to_seq
|
|> List.to_seq
|
||||||
|> Hashtbl.of_seq
|
|> Hashtbl.of_seq
|
||||||
|
|
||||||
let get_types op =
|
let get 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 =
|
|
||||||
Hashtbl.find operators op
|
Hashtbl.find operators op
|
||||||
|> List.assoc_opt typ
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module External = struct
|
module External = struct
|
||||||
|
|
@ -193,60 +164,58 @@ module External = struct
|
||||||
d /. 180. *. Float.pi
|
d /. 180. *. Float.pi
|
||||||
|
|
||||||
let floatfun f = function
|
let floatfun f = function
|
||||||
| Float n -> Float (f n)
|
| [Float n] -> Float (f n)
|
||||||
| v -> raise @@ Type.Invalid (Value.typeof v)
|
| [v] -> raise @@ Type.Invalid (Value.typeof v)
|
||||||
|
| _ -> invalid_arg "External.floatfun"
|
||||||
|
|
||||||
let apply f args =
|
let apply f args =
|
||||||
match f, args with
|
let f = match f with
|
||||||
| "sin", [n] -> floatfun Float.sin n
|
| "sin" -> floatfun Float.sin
|
||||||
| "cos", [n] -> floatfun Float.cos n
|
| "cos" -> floatfun Float.cos
|
||||||
| "tan", [n] -> floatfun Float.tan n
|
| "tan" -> floatfun Float.tan
|
||||||
| "deg", [n] -> floatfun deg n
|
| "deg" -> floatfun deg
|
||||||
| "rad", [n] -> floatfun rad n
|
| "rad" -> floatfun rad
|
||||||
| _ -> raise @@ Invalid f
|
| _ -> raise @@ Invalid f
|
||||||
|
in
|
||||||
|
f args
|
||||||
end
|
end
|
||||||
|
|
||||||
let assert_same_length vars args =
|
let find_operator op ts =
|
||||||
let vl = List.length vars
|
let filter t =
|
||||||
and al = List.length args in
|
List.filter (fun (ts, _) ->
|
||||||
if vl > al then
|
match ts with [] -> false | x::_ -> t=x)
|
||||||
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
|
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 open Value in
|
||||||
let t1 = typeof l and t2 = typeof r in
|
match find_operator op [typeof l; typeof r] with
|
||||||
let t1, t2 = resolve_type op (t1, t2) in
|
| None -> raise No_operation
|
||||||
let rec promote_until t x =
|
| Some (ts, f) ->
|
||||||
if typeof x = t
|
let vs = promote_values ts [l; r] in
|
||||||
then x
|
f vs
|
||||||
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
|
|
||||||
|
|
||||||
exception Unbound of string
|
exception Unbound of string
|
||||||
|
|
||||||
|
|
@ -270,13 +239,8 @@ let rec eval env ast =
|
||||||
let env = Env.bind (v, aux e) env in
|
let env = Env.bind (v, aux e) env in
|
||||||
eval env f
|
eval env f
|
||||||
|
|
||||||
| Unary (op, t) ->
|
| Unary (op, v) -> unary op (aux v)
|
||||||
let t = aux t in
|
| Binop (l, op, r) -> binop op (aux l) (aux r)
|
||||||
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
|
|
||||||
| If (co, th, el) ->
|
| If (co, th, el) ->
|
||||||
begin match aux co with
|
begin match aux co with
|
||||||
| Bool true -> aux th
|
| Bool true -> aux th
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue