aboutsummaryrefslogtreecommitdiff
path: root/lib/syntax/check.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/syntax/check.ml')
-rw-r--r--lib/syntax/check.ml408
1 files changed, 193 insertions, 215 deletions
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 3e01e64..10e4809 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -54,26 +54,36 @@ type t =
module_ :
(module S.Analyzer
with type Expression.t = 'a
- and type Instruction.t = 'b
- and type Location.t = 'c);
+ and type Expression.t' = 'b
+ and type Instruction.t = 'c
+ and type Instruction.t' = 'd
+ and type Location.t = 'e);
expr_witness : 'a Id.typeid;
- instr_witness : 'b Id.typeid;
- location_witness : 'c Id.typeid;
+ expr' : ('b * Report.t list) Id.typeid;
+ instr_witness : 'c Id.typeid;
+ instr' : ('d * Report.t list) Id.typeid;
+ location_witness : 'e Id.typeid;
}
-> 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 =
+ with type Expression.t = _
+ and type Expression.t' = _
+ and type Instruction.t = _
+ and type Instruction.t' = _
+ and type Location.t = 'a) ->
+ 'a Id.typeid * t =
fun module_ ->
let expr_witness = Id.newtype ()
+ and expr' = Id.newtype ()
and instr_witness = Id.newtype ()
+ and instr' = 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)
+ let t =
+ E { module_; expr_witness; expr'; instr_witness; instr'; location_witness }
+ in
+ (location_witness, t)
module type App = sig
val t : t array
@@ -82,7 +92,7 @@ end
module Helper = struct
type 'a args_list = { witness : 'a Id.typeid; values : 'a S.repr list }
(** This types helps the compiler to know which kind of arguments are hold
- inside the list. This is just a list with the additionnal witnesse
+ inside the list. This is just a list with the additionnal witness
information *)
(** Extract all the lines from the given module
@@ -97,15 +107,24 @@ module Helper = struct
~f:(fun (type a) ({ values; witness } : a args_list) t : a args_list ->
match get witness (Array.get t i) with
| None -> failwith "Does not match"
- | Some value_1 ->
- { values = (fun r -> (value_1, r)) :: values; witness })
+ | Some value_1 -> { values = (fun _ -> value_1) :: values; witness })
in
{ result with values = result.values }
- let map_args report args =
- List.fold_left_map args ~init:report ~f:(fun report v ->
- let v, result = v report in
- (result, v))
+ type 'a expr_list = { witness : 'a Id.typeid; values : 'a list }
+
+ let expr_i : result array list -> 'a Id.typeid -> int -> 'a expr_list =
+ fun args witness i ->
+ let result =
+ List.fold_left args ~init:{ values = []; witness }
+ ~f:(fun (type a) ({ values; witness } : a expr_list) t : a expr_list ->
+ match get witness (Array.get t i) with
+ | None -> failwith "Does not match"
+ | Some value_1 -> { values = value_1 :: values; witness })
+ in
+ { result with values = result.values }
+
+ let map_args report args = List.map args ~f:(fun v -> v report)
end
module Make (A : App) = struct
@@ -113,31 +132,23 @@ module Make (A : App) = struct
type t = result array
type t' = result array
- let literal : S.pos -> string -> t S.repr =
- fun pos value report ->
- let report, values =
- Array.fold_left_map A.t ~init:report
- ~f:(fun report (E { module_ = (module S); expr_witness; _ }) ->
- let value, report = S.Expression.literal pos value report in
- (report, R { value; witness = expr_witness }))
- in
- (values, report)
-
- let integer : S.pos -> string -> t S.repr =
- fun pos value report ->
- let report, values =
- Array.fold_left_map A.t ~init:report
- ~f:(fun report (E { module_ = (module S); expr_witness; _ }) ->
- let value, report = S.Expression.integer pos value report in
- (report, R { value; witness = expr_witness }))
- in
- (values, report)
+ let literal : S.pos -> string -> t =
+ fun pos value ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) ->
+ let value = S.Expression.literal pos value in
+ R { value; witness = expr_witness })
+
+ let integer : S.pos -> string -> t =
+ fun pos value ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) ->
+ let value = S.Expression.integer pos value in
+ R { value; witness = expr_witness })
(** Unary operator like [-123] or [+'Text']*)
- let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
- fun pos op values report ->
+ let uoperator : S.pos -> T.uoperator -> t -> t =
+ fun pos op values ->
(* Evaluate the nested expression *)
- let results, report = values report in
+ let results = values in
(* Now evaluate the remaining expression.
@@ -148,7 +159,6 @@ module Make (A : App) = struct
[fold_left2] and accumulate the report inside the closure, because I
don’t manage the order of the results.
*)
- let report = ref report in
let results =
Array.map2 A.t results
~f:(fun (E { module_ = (module S); expr_witness; _ }) value ->
@@ -156,26 +166,18 @@ module Make (A : App) = struct
| None -> failwith "Does not match"
| Some value ->
(* Evaluate the single expression *)
- let value, report' =
- S.Expression.uoperator pos op (fun r -> (value, r)) !report
- in
- report := report';
+ let value = S.Expression.uoperator pos op value in
R { witness = expr_witness; value })
in
- (results, !report)
+ results
(** Basically the same as uoperator, but operate over two operands instead
of a single one.
In order to operate over the values (application, op1, op2) I’ve
written a function [take_arg] which works like a [Array.map3] *)
- let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
- fun pos op expr1 expr2 report ->
- let expr1, report = expr1 report in
- let expr2, report = expr2 report in
-
- let report = ref report in
-
+ let boperator : S.pos -> T.boperator -> t -> t -> t =
+ fun pos op expr1 expr2 ->
let take_arg : result array -> result array -> result array =
fun expr1 expr2 ->
let len = Array.length A.t in
@@ -188,189 +190,158 @@ module Make (A : App) = struct
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;
+ let value = S.Expression.boperator pos op value_1 value_2 in
R { witness = expr_witness; value }
| _ -> failwith "Does not match")
in
- let results = take_arg expr1 expr2 in
- (results, !report)
+ take_arg expr1 expr2
(** Call a function. The functions list is hardcoded in lib/lexer.mll *)
- let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
- fun pos func args report ->
- let report, args = Helper.map_args report args in
- let report = ref report and len = Array.length A.t in
+ let function_ : S.pos -> T.function_ -> t list -> t =
+ fun pos func args ->
+ let len = Array.length A.t in
let result =
Array.init len ~f:(fun i ->
let (E { module_ = (module S); expr_witness; _ }) =
Array.get A.t i
in
(* Extract the arguments for each module *)
- let args_i = Helper.args_i args expr_witness i in
-
- let value, r =
- S.Expression.function_ pos func (List.rev args_i.values) !report
- in
- report := r;
+ let args_i = List.rev (Helper.expr_i args expr_witness i).values in
+ let value = S.Expression.function_ pos func args_i in
R { witness = expr_witness; value })
in
- (result, !report)
+ result
- let ident : (S.pos, t S.repr) S.variable -> t S.repr =
- fun { pos : S.pos; name : string; index : t S.repr option } report ->
+ let ident : (S.pos, t) S.variable -> t =
+ fun { pos : S.pos; name : string; index : t option } ->
let len = Array.length A.t in
- let report = ref report in
- let index =
- Option.map
- (fun v ->
- let v, r = v !report in
- report := r;
- v)
- index
- in
-
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
+
+ match index with
+ | None ->
+ (* Easest case, just return the plain ident *)
+ let value = S.Expression.ident { pos; name; index = None } in
+ R { witness = expr_witness; value }
+ | Some t -> (
+ match get expr_witness (Array.get t i) with
+ | None -> failwith "Does not match"
+ | Some value_1 ->
+ let value =
+ S.Expression.ident { pos; name; index = Some value_1 }
+ in
+ R { witness = expr_witness; value }))
+
+ (** Convert each internal represention for the expression into its external
+ representation *)
+ let v : t -> t' * Report.t list =
+ fun t ->
let result =
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr_witness; _ }) =
- Array.get A.t i
- in
-
- match index with
- | None ->
- (* Easest case, just return the plain ident *)
- let value, r =
- S.Expression.ident { pos; name; index = None } !report
- in
- report := r;
- R { witness = expr_witness; value }
- | Some t -> (
- match get expr_witness (Array.get t i) with
- | None -> failwith "Does not match"
- | Some value_1 ->
- let value, r =
- S.Expression.ident
- { pos; name; index = Some (fun r -> (value_1, r)) }
- !report
- in
- report := r;
- R { witness = expr_witness; value }))
+ Array.map2 A.t t
+ ~f:(fun (E { module_ = (module S); expr_witness; expr'; _ }) result ->
+ match get expr_witness result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let value = S.Expression.v value in
+ R { witness = expr'; value })
in
- (result, !report)
-
- let v : t * Report.t list -> t' * Report.t list = fun t -> t
+ (result, [])
end
module Instruction :
S.Instruction
- with type expression = Expression.t' S.repr
+ with type expression = Expression.t' * Report.t list
and type t' = result array = struct
- type expression = Expression.t' S.repr
+ type expression = Expression.t' * Report.t list
type t = result array
type t' = result array
let location : S.pos -> string -> t S.repr =
fun pos label report ->
- let report, values =
- Array.fold_left_map A.t ~init:report
- ~f:(fun report (E { module_ = (module S); instr_witness; _ }) ->
- let value, report = S.Instruction.location pos label report in
-
- (report, R { value; witness = instr_witness }))
+ let values =
+ Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+ let value = S.Instruction.location pos label report in
+ R { value; witness = instr_witness })
in
- (values, report)
+ values
let comment : S.pos -> t S.repr =
fun pos report ->
- let report, values =
- Array.fold_left_map A.t ~init:report
- ~f:(fun report (E { module_ = (module S); instr_witness; _ }) ->
- let value, report = S.Instruction.comment pos report in
-
- (report, R { value; witness = instr_witness }))
+ let values =
+ Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+ let value = S.Instruction.comment pos report in
+ R { value; witness = instr_witness })
in
- (values, report)
+ values
let expression : expression -> t S.repr =
fun expr report ->
- let expr, report = expr report in
- let report = ref report in
+ let expr, _report = expr in
let results =
Array.map2 A.t expr
~f:(fun
- (E { module_ = (module S); instr_witness; expr_witness; _ })
- (R { value; witness })
- ->
- match Id.try_cast witness expr_witness with
+ (E { module_ = (module S); instr_witness; expr'; _ }) result ->
+ match get expr' result with
| None -> failwith "Does not match"
- | Some Eq ->
+ | Some value ->
(* The evaluate the instruction *)
- let value, r =
- S.Instruction.expression
- (fun r -> S.Expression.v (value, r))
- !report
- in
- report := r;
+ let value = S.Instruction.expression value report in
R { value; witness = instr_witness })
in
- (results, !report)
+ results
let call : S.pos -> T.keywords -> expression list -> t S.repr =
fun pos keyword args report ->
- let report, args = Helper.map_args report args in
- let report = ref report and len = Array.length A.t in
+ (* The arguments are given like an array of array. Each expression is
+ actually the list of each expression in the differents modules. *)
+
+ (* Accumulate the results *)
+ let report, args =
+ List.fold_left_map args ~init:report ~f:(fun report (v, r) ->
+ (r @ report, v))
+ in
+
+ let len = Array.length A.t in
let result =
Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr_witness; instr_witness; _ }) =
+ let (E { module_ = (module S); expr'; instr_witness; _ }) =
Array.get A.t i
in
- let args_i = Helper.args_i args expr_witness i in
- let values =
- List.rev_map args_i.values ~f:(fun value r ->
- S.Expression.v (value r))
- in
- let value, r = S.Instruction.call pos keyword values !report in
- report := r;
+ let values = List.rev (Helper.expr_i args expr' i).values in
+
+ let value = S.Instruction.call pos keyword values report in
R { witness = instr_witness; value })
in
- (result, !report)
+ result
let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
- fun pos ~label instructions report ->
- let label, report = label report in
- let report, instructions = Helper.map_args report instructions in
- let report = ref report and len = Array.length A.t in
+ fun pos ~label instructions _report ->
+ let label, report = label in
+ let instructions = Helper.map_args report instructions in
+ let len = Array.length A.t in
let result =
Array.init len ~f:(fun i ->
- let (E { module_ = (module S); instr_witness; expr_witness; _ }) =
+ let (E { module_ = (module S); instr_witness; expr'; _ }) =
Array.get A.t i
in
- let args_i = Helper.args_i instructions instr_witness i in
let values =
- List.rev_map args_i.values ~f:(fun value r -> value r)
+ List.rev (Helper.args_i instructions instr_witness i).values
in
- match get expr_witness (Array.get label i) with
+ match get expr' (Array.get label i) with
| None -> failwith "Does not match"
| 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
+ let value =
+ S.Instruction.act pos ~label:label_i values report
in
- report := r;
R { witness = instr_witness; value })
in
- (result, !report)
+ result
(* I think it’s one of the longest module I’ve ever written in OCaml… *)
@@ -380,14 +351,14 @@ module Make (A : App) = struct
T.assignation_operator ->
expression ->
t S.repr =
- fun pos { pos = var_pos; name; index } op expression report ->
- let expression, report = expression report in
+ fun pos { pos = var_pos; name; index } op expression _report ->
+ let expression, report = expression in
let report = ref report and len = Array.length A.t in
let index =
Option.map
(fun v ->
- let v, r = v !report in
+ let v, r = v in
report := r;
v)
index
@@ -395,49 +366,44 @@ module Make (A : App) = struct
let result =
Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr_witness; expr_witness; _ }) =
+ let (E { module_ = (module A); instr_witness; expr'; _ }) =
Array.get A.t i
in
let index_i =
Option.map
(fun expression ->
- match get expr_witness (Array.get expression i) with
+ match get expr' (Array.get expression i) with
| None -> failwith "Does not match"
- | Some value ->
- let value r = A.Expression.v (value, r) in
- value)
+ | Some value -> value)
index
in
let variable = S.{ pos = var_pos; name; index = index_i } in
- match get expr_witness (Array.get expression i) with
+ match get expr' (Array.get expression i) with
| None -> failwith "Does not match"
| Some value ->
- let value, r =
- A.Instruction.assign pos variable op
- (fun r -> A.Expression.v (value, r))
- !report
+ let value =
+ A.Instruction.assign pos variable op value !report
in
- report := r;
R { value; witness = instr_witness })
in
- (result, !report)
+ result
(** Helper function used to prepare the clauses *)
let map_clause :
Report.t list ->
(expression, t) S.clause ->
Report.t list * (S.pos * Expression.t' * t list) =
- fun report clause ->
+ fun _report clause ->
let clause_pos, expression, t = clause in
- let expression, report = expression report in
- let report, t =
- List.fold_left_map t ~init:report ~f:(fun report t ->
- let t, report = t report in
- (report, t))
+ let expression, report = expression in
+ let t =
+ List.map t ~f:(fun t ->
+ let t = t report in
+ t)
in
let clause = (clause_pos, expression, t) in
(report, clause)
@@ -450,13 +416,13 @@ module Make (A : App) = struct
(b -> 'c) ->
S.pos * result array * result array list ->
('c, a) S.clause =
- fun i instr_witness expr_witness f clause ->
+ fun i instr_witness expr' f clause ->
let pos_clause, expr_clause, ts = clause in
- match get expr_witness (Array.get expr_clause i) with
+ match get expr' (Array.get expr_clause i) with
| None -> failwith "Does not match"
| 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 ts = List.rev ts.values in
let clause = (pos_clause, f value, ts) in
clause
@@ -469,28 +435,29 @@ module Make (A : App) = struct
fun pos clause ~elifs ~else_ report ->
(* First, apply the report for all the instructions *)
let report, clause = map_clause report clause in
+
let report, elifs = List.fold_left_map elifs ~init:report ~f:map_clause in
let report, else_ =
match else_ with
| None -> (report, None)
| Some (pos, instructions) ->
- let report, instructions = Helper.map_args report instructions in
+ let instructions = Helper.map_args report instructions in
(report, Some (pos, instructions))
in
- let report = ref report and len = Array.length A.t in
+ let len = Array.length A.t in
let result =
Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr_witness; expr_witness; _ }) =
+ let (E { module_ = (module A); instr_witness; expr'; _ }) =
Array.get A.t i
in
(* This function helps to build the expression in the clauses *)
- let f v r = A.Expression.v (v, r) in
+ let f = Fun.id in
- let clause = rebuild_clause i instr_witness expr_witness f clause
+ let clause = rebuild_clause i instr_witness expr' f clause
and elifs =
- List.map elifs ~f:(rebuild_clause i instr_witness expr_witness f)
+ List.map elifs ~f:(rebuild_clause i instr_witness expr' f)
and else_ =
match else_ with
| None -> None
@@ -499,45 +466,56 @@ module Make (A : App) = struct
Some (pos, List.rev elses.values)
in
- let value, r = A.Instruction.if_ pos clause ~elifs ~else_ !report in
- report := r;
+ let value = A.Instruction.if_ pos clause ~elifs ~else_ report in
R { value; witness = instr_witness })
in
- (result, !report)
+ result
- let v : t * Report.t list -> t' * Report.t list = fun t -> t
+ (** This code is almost a copy/paste from Expression.v but I did not found
+ a way to factorize it. *)
+ let v : t -> t' * Report.t list =
+ fun t ->
+ let result =
+ Array.map2 A.t t
+ ~f:(fun
+ (E { module_ = (module S); instr_witness; instr'; _ }) result ->
+ match get instr_witness result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let value = S.Instruction.v value in
+ R { witness = instr'; value })
+ in
+ (result, [])
end
module Location :
- S.Location with type t = result array and type instruction = Instruction.t' =
- struct
- type instruction = Instruction.t'
+ S.Location
+ with type t = result array
+ and type instruction = (Instruction.t' * Report.t list) S.repr = struct
+ type instruction = (Instruction.t' * Report.t list) S.repr
type t = result array
- let location : S.pos -> instruction S.repr list -> t S.repr =
+ let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
fun pos instructions report ->
ignore pos;
- let report, instructions = Helper.map_args report instructions in
+ (* Extract the instructions and accumulate the result *)
+ let instructions = Helper.map_args report instructions in
+
+ let report, args =
+ List.fold_left_map instructions ~init:report ~f:(fun report (v, r) ->
+ (r @ report, v))
+ in
let report = ref report and len = Array.length A.t in
let result =
Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr_witness; location_witness; _ })
- =
+ let (E { module_ = (module A); instr'; location_witness; _ }) =
Array.get A.t i
in
- let instructions_i : A.Instruction.t Helper.args_list =
- Helper.args_i instructions instr_witness i
- in
- let inst : A.Instruction.t S.repr list = instructions_i.values in
- let instructions : A.Instruction.t' S.repr list =
- List.rev_map inst ~f:(fun value report ->
- let value, report = value report in
- A.Instruction.v (value, report))
- in
+ let instructions = List.rev (Helper.args_i args instr' i).values in
let value, re = A.Location.location pos instructions !report in
report := re;
R { value; witness = location_witness })
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-18 19:19:49 +0000