From 28981268a4eb93bba918eb29ecf57de64d4b0eff Mon Sep 17 00:00:00 2001 From: Chimrod <> Date: Sat, 14 Oct 2023 18:36:46 +0200 Subject: Applied this new way to check the errors in the main code --- lib/syntax/check.ml | 95 ++++++++++++++++++++++++++++------------------------- 1 file changed, 50 insertions(+), 45 deletions(-) (limited to 'lib/syntax/check.ml') diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml index 5ef2621..3e9d255 100644 --- a/lib/syntax/check.ml +++ b/lib/syntax/check.ml @@ -45,7 +45,11 @@ end associate with. *) type result = R : { value : 'a; witness : 'a Id.typeid } -> result -type transform = +let get : type a. a Id.typeid -> result -> a option = + fun typeid (R { value; witness }) -> + match Id.try_cast typeid witness with Some Eq -> Some value | None -> None + +type t = | E : { module_ : (module S.Analyzer @@ -56,10 +60,23 @@ type transform = instr_witness : 'b Id.typeid; location_witness : 'c Id.typeid; } - -> transform + -> t + +let build : + (module S.Analyzer + with type Expression.t = 'a + and type Instruction.t = 'b + and type Location.t = 'c) -> + 'a Id.typeid * 'b Id.typeid * 'c Id.typeid * t = + fun module_ -> + let expr_witness = Id.newtype () + and instr_witness = Id.newtype () + and location_witness = Id.newtype () in + let t = E { module_; expr_witness; instr_witness; location_witness } in + (expr_witness, instr_witness, location_witness, t) module type App = sig - val t : transform array + val t : t array end module Helper = struct @@ -78,10 +95,10 @@ module Helper = struct let result = List.fold_left args ~init:{ values = []; witness } ~f:(fun (type a) ({ values; witness } : a args_list) t : a args_list -> - let (R { value = value_1; witness = witness_1 }) = Array.get t i in - match Id.try_cast witness witness_1 with + match get witness (Array.get t i) with | None -> failwith "Does not match" - | Some Eq -> { values = (fun r -> (value_1, r)) :: values; witness }) + | Some value_1 -> + { values = (fun r -> (value_1, r)) :: values; witness }) in { result with values = result.values } @@ -134,13 +151,10 @@ module Make (A : App) = struct let report = ref report in let results = Array.map2 A.t results - ~f:(fun - (E { module_ = (module S); expr_witness; _ }) - (R { value; witness }) - -> - match Id.try_cast witness expr_witness with + ~f:(fun (E { module_ = (module S); expr_witness; _ }) value -> + match get expr_witness value with | None -> failwith "Does not match" - | Some Eq -> + | Some value -> (* Evaluate the single expression *) let value, report' = S.Expression.uoperator pos op (fun r -> (value, r)) !report @@ -169,22 +183,20 @@ module Make (A : App) = struct let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in - let (R { value = value_1; witness }) = Array.get expr1 i in - match Id.try_cast expr_witness witness with - | None -> failwith "Does not match" - | Some Eq -> ( - let (R { value = value_2; witness }) = Array.get expr2 i in - match Id.try_cast expr_witness witness with - | None -> failwith "Does not match" - | Some Eq -> - let value, r = - S.Expression.boperator pos op - (fun r -> (value_1, r)) - (fun r -> (value_2, r)) - !report - in - report := r; - R { witness = expr_witness; value })) + match + ( get expr_witness (Array.get expr1 i), + get expr_witness (Array.get expr2 i) ) + with + | Some value_1, Some value_2 -> + let value, r = + S.Expression.boperator pos op + (fun r -> (value_1, r)) + (fun r -> (value_2, r)) + !report + in + report := r; + R { witness = expr_witness; value } + | _ -> failwith "Does not match") in let results = take_arg expr1 expr2 in @@ -240,11 +252,9 @@ module Make (A : App) = struct report := r; R { witness = expr_witness; value } | Some t -> ( - let (R { value = value_1; witness }) = Array.get t i in - - match Id.try_cast expr_witness witness with + match get expr_witness (Array.get t i) with | None -> failwith "Does not match" - | Some Eq -> + | Some value_1 -> let value, r = S.Expression.ident { pos; name; index = Some (fun r -> (value_1, r)) } @@ -348,11 +358,10 @@ module Make (A : App) = struct let values = List.rev_map args_i.values ~f:(fun value r -> value r) in - let (R { value = label_i; witness }) = Array.get label i in - match Id.try_cast witness expr_witness with + match get expr_witness (Array.get label i) with | None -> failwith "Does not match" - | Some Eq -> + | Some label_i -> let label_i r = S.Expression.v (label_i, r) in let value, r = S.Instruction.act pos ~label:label_i values !report @@ -393,21 +402,18 @@ module Make (A : App) = struct let index_i = Option.map (fun expression -> - let (R { value; witness }) = Array.get expression i in - - match Id.try_cast witness expr_witness with + match get expr_witness (Array.get expression i) with | None -> failwith "Does not match" - | Some Eq -> + | Some value -> let value r = A.Expression.v (value, r) in value) index in let variable = S.{ pos = var_pos; name; index = index_i } in - let (R { value; witness }) = Array.get expression i in - match Id.try_cast witness expr_witness with + match get expr_witness (Array.get expression i) with | None -> failwith "Does not match" - | Some Eq -> + | Some value -> let value, r = A.Instruction.assign pos variable op (fun r -> A.Expression.v (value, r)) @@ -446,10 +452,9 @@ module Make (A : App) = struct ('c, a) S.clause = fun i instr_witness expr_witness f clause -> let pos_clause, expr_clause, ts = clause in - let (R { value; witness }) = Array.get expr_clause i in - match Id.try_cast witness expr_witness with + match get expr_witness (Array.get expr_clause i) with | None -> failwith "Does not match" - | Some Eq -> + | Some value -> let ts = Helper.args_i ts instr_witness i in let ts = List.rev_map ts.values ~f:(fun value r -> value r) in let clause = (pos_clause, f value, ts) in -- cgit v1.2.3