aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bin/qsp_parser.ml11
-rw-r--r--lib/qparser/parser.mly10
-rw-r--r--lib/qparser/qsp_expression.mly2
-rw-r--r--lib/qparser/qsp_instruction.mly14
-rw-r--r--lib/syntax/S.ml71
-rw-r--r--lib/syntax/check.ml408
-rw-r--r--lib/syntax/check.mli15
-rw-r--r--lib/syntax/dead_end.ml18
-rw-r--r--lib/syntax/default.ml22
-rw-r--r--lib/syntax/report.ml18
-rw-r--r--lib/syntax/tree.ml96
-rw-r--r--lib/syntax/type_of.ml147
-rw-r--r--test/syntax.ml2
13 files changed, 437 insertions, 397 deletions
diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml
index 8ab442b..cf64fed 100644
--- a/bin/qsp_parser.ml
+++ b/bin/qsp_parser.ml
@@ -1,8 +1,6 @@
open StdLabels
module Report = Qsp_syntax.Report
-type result = Report.t list [@@deriving show]
-
(** Filter the results given by the analysis *)
let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list =
fun filters reports r ->
@@ -19,8 +17,8 @@ type ctx = { error_nb : int; warn_nb : int; debug_nb : int }
(*
List all the controls to apply
*)
-let _, _, _, e1 = Qsp_syntax.Check.build (module Qsp_syntax.Type_of)
-let _, _, _, e2 = Qsp_syntax.Check.build (module Qsp_syntax.Dead_end)
+let _, e1 = Qsp_syntax.Check.build (module Qsp_syntax.Type_of)
+let _, e2 = Qsp_syntax.Check.build (module Qsp_syntax.Dead_end)
module Check = Qsp_syntax.Check.Make (struct
let t = [| e1; e2 |]
@@ -34,7 +32,8 @@ let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
let result =
Qparser.Analyzer.parse (module Check) lexbuf
|> Result.map (fun (_, f) ->
- List.fold_left f ~init:[] ~f:(filter_report filters))
+ List.fold_left f ~init:[] ~f:(filter_report filters)
+ |> List.sort ~cmp:Report.compare)
in
match result with
| Ok report -> (
@@ -44,7 +43,7 @@ let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
| _ ->
let start_position, _ = Qparser.Lexbuf.positions lexbuf in
Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@."
- start_position.Lexing.pos_fname pp_result report;
+ start_position.Lexing.pos_fname Report.pp_result report;
List.fold_left report ~init:ctx ~f:(fun ctx report ->
match report.Report.level with
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index 63b9577..d84e534 100644
--- a/lib/qparser/parser.mly
+++ b/lib/qparser/parser.mly
@@ -1,4 +1,3 @@
-
%{
module T = Qsp_syntax.T
open StdLabels
@@ -6,8 +5,7 @@
type action_block =
{ loc : Qsp_syntax.S.pos
; expression :
- Qsp_syntax.Report.t list
- -> Analyzer.Expression.t' * Qsp_syntax.Report.t list
+ Analyzer.Expression.t' * Qsp_syntax.Report.t list
; body : Analyzer.Instruction.t Qsp_syntax.S.repr list
; pos : Qsp_syntax.S.pos
; clauses : (
@@ -21,7 +19,7 @@
%}
%parameter<Analyzer: Qsp_syntax.S.Analyzer>
-%start <Analyzer.Location.t Qsp_syntax.S.repr>main
+%start <(Analyzer.Location.t * Qsp_syntax.Report.t list) Qsp_syntax.S.repr>main
%on_error_reduce expression instruction unary_operator assignation_operator
%%
@@ -77,7 +75,7 @@ line_statement:
END TOKEN?
line_sep
{
- let expression = Helper.v e in
+ let expression = Helper.v' e in
let clauses = match b with
| None -> None
| Some (elifs, clauses) ->
@@ -86,7 +84,7 @@ line_statement:
| _ ->
List.map elifs
~f:(fun ((pos:Qsp_syntax.S.pos), e, instructions) ->
- let e = Helper.v e in
+ let e = Helper.v' e in
(pos, e, instructions)
)
diff --git a/lib/qparser/qsp_expression.mly b/lib/qparser/qsp_expression.mly
index 799be31..362c717 100644
--- a/lib/qparser/qsp_expression.mly
+++ b/lib/qparser/qsp_expression.mly
@@ -1,5 +1,3 @@
-(* %start <(Elements.pos) Elements.exppression>expression *)
-
%%
%public arguments(X):
diff --git a/lib/qparser/qsp_instruction.mly b/lib/qparser/qsp_instruction.mly
index 8272cff..e8f5a77 100644
--- a/lib/qparser/qsp_instruction.mly
+++ b/lib/qparser/qsp_instruction.mly
@@ -18,7 +18,7 @@ argument(X):
%public inline_action:
| a = onliner(ACT)
{ let loc, label, statements, _, _ = a in
- let label = Helper.v label in
+ let label = Helper.v' label in
Analyzer.Instruction.act loc ~label statements
}
| a = onliner(IF)
@@ -30,7 +30,7 @@ argument(X):
| Some instructions -> Some ($loc(else_opt), [ instructions ]) in
Analyzer.Instruction.if_
loc
- (loc_s, Helper.v expr, statements)
+ (loc_s, Helper.v' expr, statements)
~elifs
~else_
}
@@ -42,21 +42,21 @@ argument(X):
Analyzer.Instruction.if_
loc
- (loc_s, Helper.v expr, statements)
+ (loc_s, Helper.v' expr, statements)
~elifs
~else_
}
single_instruction:
| expr = expression
{
- let expr = Helper.v expr in
+ let expr = Helper.v' expr in
Analyzer.Instruction.expression expr
}
| e = let_assignation { e }
| k = keyword
args = argument(expression)
{
- let args = List.map args ~f:(Helper.v) in
+ let args = List.map args ~f:(Helper.v') in
Analyzer.Instruction.call $loc k args
}
@@ -69,8 +69,8 @@ let_assignation:
op = assignation_operator
value = expression
{
- let variable = Helper.variable variable
- and value = Helper.v value in
+ let variable = Helper.variable' variable
+ and value = Helper.v' value in
Analyzer.Instruction.assign $loc variable op value
}
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index 710eb59..b52365d 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -13,7 +13,7 @@
*)
-type 'a repr = Report.t list -> 'a * Report.t list
+type 'a repr = Report.t list -> 'a
type pos = Lexing.position * Lexing.position
(** Starting and ending position for the given location *)
@@ -34,23 +34,23 @@ module type Expression = sig
type t'
(** External type used outside of the module *)
- val v : t * Report.t list -> t' * Report.t list
- val ident : (pos, t repr) variable -> t repr
+ val v : t -> t' * Report.t list
+ val ident : (pos, t) variable -> t
(*
Basic values, text, number…
*)
- val integer : pos -> string -> t repr
- val literal : pos -> string -> t repr
+ val integer : pos -> string -> t
+ val literal : pos -> string -> t
- val function_ : pos -> T.function_ -> t repr list -> t repr
+ val function_ : pos -> T.function_ -> t list -> t
(** Call a function. The functions list is hardcoded in lib/lexer.mll *)
- val uoperator : pos -> T.uoperator -> t repr -> t repr
+ val uoperator : pos -> T.uoperator -> t -> t
(** Unary operator like [-123] or [+'Text']*)
- val boperator : pos -> T.boperator -> t repr -> t repr -> t repr
+ val boperator : pos -> T.boperator -> t -> t -> t
(** Binary operator, for a comparaison, or an operation *)
end
@@ -61,7 +61,7 @@ module type Instruction = sig
type t'
(** External type used outside of the module *)
- val v : t * Report.t list -> t' * Report.t list
+ val v : t -> t' * Report.t list
type expression
@@ -98,17 +98,25 @@ module type Location = sig
type t
type instruction
- val location : pos -> instruction repr list -> t repr
+ val location : pos -> instruction list -> (t * Report.t list) repr
end
module type Analyzer = sig
module Expression : Expression
- module Instruction : Instruction with type expression = Expression.t' repr
- module Location : Location with type instruction = Instruction.t'
+
+ module Instruction :
+ Instruction with type expression = Expression.t' * Report.t list
+
+ module Location :
+ Location with type instruction = (Instruction.t' * Report.t list) repr
end
(** Helper module used in order to convert elements from the differents
- representation levels *)
+ representation levels.
+
+ Thoses functions are intended to be used in the menhir parser, in order to
+ limit the code in the mly file.
+*)
module Helper (E : sig
type t
(** Internal type used in the evaluation *)
@@ -116,18 +124,39 @@ module Helper (E : sig
type t'
(** External type used outside of the module *)
- val v : t * Report.t list -> t' * Report.t list
+ val v : t -> t' * Report.t list
end) : sig
- val v : E.t repr -> E.t' repr
+ val v : E.t repr -> Report.t list -> E.t' * Report.t list
+ (** Convert an instruction from the internal representation *)
+
+ val v' : E.t -> E.t' * Report.t list
+ (** Convert an expression from the internal representation *)
- val variable : (pos, E.t repr) variable -> (pos, E.t' repr) variable
+ val variable :
+ (pos, E.t) variable -> (pos, Report.t list -> E.t' * Report.t list) variable
+
+ val variable' : (pos, E.t) variable -> (pos, E.t' * Report.t list) variable
(** Convert a variable from the [Expression.t] into [Expression.t'] *)
end = struct
- let v : E.t repr -> E.t' repr =
+ let v : E.t repr -> Report.t list -> E.t' * Report.t list =
fun v report ->
- let value, report = v report in
- E.v (value, report)
+ let value = v report in
+ E.v value
+
+ let v' : E.t -> E.t' * Report.t list = fun v -> E.v v
+
+ let variable :
+ (pos, E.t) variable ->
+ (pos, Report.t list -> E.t' * Report.t list) variable =
+ fun variable ->
+ let v' : E.t -> Report.t list -> E.t' * Report.t list =
+ fun t report ->
+ ignore report;
+ E.v t
+ in
+
+ { variable with index = Option.map v' variable.index }
- let variable : (pos, E.t repr) variable -> (pos, E.t' repr) variable =
- fun variable -> { variable with index = Option.map v variable.index }
+ let variable' : (pos, E.t) variable -> (pos, E.t' * Report.t list) variable =
+ fun variable -> { variable with index = Option.map v' variable.index }
end
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 })
diff --git a/lib/syntax/check.mli b/lib/syntax/check.mli
index c831b67..28ff49e 100644
--- a/lib/syntax/check.mli
+++ b/lib/syntax/check.mli
@@ -8,11 +8,16 @@ type t
val 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
-(** Build a new check from a module following S.Analyzer signature *)
+ 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
+(** Build a new check from a module following S.Analyzer signature.
+
+ Return the result type which hold the final result value, and checker
+ itself. *)
module type App = sig
val t : t array
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index 36c997f..d1683cd 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -10,21 +10,22 @@ module Expression = struct
let default = ()
end)
- let v : t * Report.t list -> t' * Report.t list = Fun.id
+ let v : t -> t' * Report.t list = fun () -> ((), [])
end
module Instruction = struct
- type expression = Expression.t' S.repr
+ type expression = Expression.t' * Report.t list
type cause = Missing_else | Unchecked_path
- type t = {
+ type state = {
block_pos : S.pos;
has_gt : bool;
is_gt : bool;
pos : (cause * S.pos) option;
}
- type t' = t
+ type t = state * Report.t list
+ type t' = state
(** For each instruction, return thoses two informations :
@@ -32,7 +33,7 @@ module Instruction = struct
- the last instruction is a [gt]
*)
- let v : t * Report.t list -> t' * Report.t list = Fun.id
+ let v : t -> t' * Report.t list = fun t -> t
let default =
{
@@ -144,14 +145,15 @@ end
module Location = struct
type t = unit
- type instruction = Instruction.t
+ type instruction = (Instruction.t' * Report.t list) S.repr
- 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 ->
( (),
List.fold_left instructions ~init:report ~f:(fun report instruction ->
- let t, report = instruction report in
+ let t, r = instruction [] in
+ let report = List.rev_append r report in
match (t.Instruction.is_gt, t.Instruction.pos) with
| false, Some (cause, value) ->
ignore cause;
diff --git a/lib/syntax/default.ml b/lib/syntax/default.ml
index dad5144..45e7c14 100644
--- a/lib/syntax/default.ml
+++ b/lib/syntax/default.ml
@@ -17,29 +17,23 @@ module Expression (T' : T) = struct
If missing, the index should be considered as [0].
*)
- let ident : (S.pos, T'.t S.repr) S.variable -> T'.t S.repr =
- fun _ report -> (T'.default, report)
+ let ident : (S.pos, T'.t) S.variable -> T'.t = fun _ -> T'.default
(*
Basic values, text, number…
*)
- let integer : S.pos -> string -> T'.t S.repr =
- fun _ _ report -> (T'.default, report)
-
- let literal : S.pos -> string -> T'.t S.repr =
- fun _ _ report -> (T'.default, report)
+ let integer : S.pos -> string -> T'.t = fun _ _ -> T'.default
+ let literal : S.pos -> string -> T'.t = fun _ _ -> T'.default
(** Call a function. The functions list is hardcoded in lib/lexer.mll *)
- let function_ : S.pos -> T.function_ -> T'.t S.repr list -> T'.t S.repr =
- fun _ _ _ report -> (T'.default, report)
+ let function_ : S.pos -> T.function_ -> T'.t list -> T'.t =
+ fun _ _ _ -> T'.default
(** Unary operator like [-123] or [+'Text']*)
- let uoperator : S.pos -> T.uoperator -> T'.t S.repr -> T'.t S.repr =
- fun _ _ _ report -> (T'.default, report)
+ let uoperator : S.pos -> T.uoperator -> T'.t -> T'.t = fun _ _ _ -> T'.default
(** Binary operator, for a comparaison, or an operation *)
- let boperator :
- S.pos -> T.boperator -> T'.t S.repr -> T'.t S.repr -> T'.t S.repr =
- fun _ _ _ _ report -> (T'.default, report)
+ let boperator : S.pos -> T.boperator -> T'.t -> T'.t -> T'.t =
+ fun _ _ _ _ -> T'.default
end
diff --git a/lib/syntax/report.ml b/lib/syntax/report.ml
index 9dae0f5..19a9104 100644
--- a/lib/syntax/report.ml
+++ b/lib/syntax/report.ml
@@ -31,6 +31,22 @@ let pp_pos : Format.formatter -> pos -> unit =
type t = { level : level; loc : pos; message : string }
[@@deriving show { with_path = false }]
+let compare : t -> t -> int =
+ fun t1 t2 ->
+ (* first compare the position *)
+ let pos1_start, pos1_end = t1.loc and pos2_start, pos2_end = t2.loc in
+ match compare pos1_start.pos_cnum pos2_start.pos_cnum with
+ | 0 -> (
+ (* Then the ending position *)
+ match compare pos1_end.pos_cnum pos2_end.pos_cnum with
+ | 0 -> (
+ (* And the level *)
+ match compare (level_to_enum t1.level) (level_to_enum t2.level) with
+ | 0 -> String.compare t1.message t2.message
+ | other -> other)
+ | other -> other)
+ | other -> other
+
let debug : pos -> string -> t =
fun loc message -> { level = Debug; loc; message }
@@ -41,3 +57,5 @@ let error : pos -> string -> t =
fun loc message -> { level = Error; loc; message }
let message level loc message = { level; loc; message }
+
+type result = t list [@@deriving show]
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index 85e130d..cf02bf6 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -36,58 +36,50 @@ module Expression : S.Expression with type t' = S.pos Ast.expression = struct
type t = S.pos Ast.expression
type t' = t
- let v : t * Report.t list -> t' * Report.t list = fun (t, r) -> (t, r)
+ let v : t -> t' * Report.t list = fun t -> (t, [])
+ let integer : S.pos -> string -> t = fun pos i -> Ast.Integer (pos, i)
+ let literal : S.pos -> string -> t = fun pos l -> Ast.Literal (pos, l)
- let integer : S.pos -> string -> t S.repr =
- fun pos i r -> (Ast.Integer (pos, i), r)
+ let function_ : S.pos -> T.function_ -> t list -> t =
+ fun pos name args -> Ast.Function (pos, name, args)
- let literal : S.pos -> string -> t S.repr =
- fun pos l r -> (Ast.Literal (pos, l), r)
+ let uoperator : S.pos -> T.uoperator -> t -> t =
+ fun pos op expression -> Ast.Op (pos, op, expression)
- let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
- fun pos name args r ->
- let args = List.map ~f:(fun f -> fst (f r)) args in
- (Ast.Function (pos, name, args), r)
+ let boperator : S.pos -> T.boperator -> t -> t -> t =
+ fun pos op op1 op2 ->
+ let op1 = op1 and op2 = op2 in
+ Ast.BinaryOp (pos, op, op1, op2)
- let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
- fun pos op expression r ->
- let expression = fst (expression r) in
- (Ast.Op (pos, op, expression), r)
-
- let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
- fun pos op op1 op2 r ->
- let op1 = fst (op1 r) and op2 = fst (op2 r) in
- (Ast.BinaryOp (pos, op, op1, op2), r)
-
- let ident : (S.pos, t S.repr) S.variable -> t S.repr =
- fun { pos; name; index } r ->
- let index = Option.map (fun i -> fst (i r)) index in
- (Ast.Ident { pos; name; index }, r)
+ let ident : (S.pos, t) S.variable -> t =
+ fun { pos; name; index } ->
+ let index = Option.map (fun i -> i) index in
+ Ast.Ident { pos; name; index }
end
module Instruction :
S.Instruction
- with type expression = Expression.t' S.repr
+ with type expression = Expression.t' * Report.t list
and type t' = S.pos Ast.statement = struct
type t = S.pos Ast.statement
type t' = t
- let v = Fun.id
+ let v : t -> t' * Report.t list = fun t -> (t, [])
- type expression = Expression.t' S.repr
+ type expression = Expression.t' * Report.t list
let call : S.pos -> T.keywords -> expression list -> t S.repr =
- fun pos name args report ->
- let args = List.map ~f:(fun f -> fst (f [])) args in
- (Ast.Call (pos, name, args), report)
+ fun pos name args _ ->
+ let args = List.map ~f:fst args in
+ Ast.Call (pos, name, args)
let location : S.pos -> string -> t S.repr =
- fun loc label report -> (Ast.Location (loc, label), report)
+ fun loc label _ -> Ast.Location (loc, label)
- let comment : S.pos -> t S.repr = fun pos report -> (Ast.Comment pos, report)
+ let comment : S.pos -> t S.repr = fun pos _ -> Ast.Comment pos
let expression : expression -> t S.repr =
- fun expr report -> (Ast.Expression (fst (expr [])), report)
+ fun expr _ -> Ast.Expression (fst expr)
let if_ :
S.pos ->
@@ -95,26 +87,26 @@ module Instruction :
elifs:(expression, t) S.clause list ->
else_:(S.pos * t S.repr list) option ->
t S.repr =
- fun pos predicate ~elifs ~else_ report ->
+ fun pos predicate ~elifs ~else_ _ ->
let clause (pos, expr, repr) =
- let repr = List.map ~f:(fun instr -> fst @@ instr []) repr in
- (pos, fst @@ expr [], repr)
+ let repr = List.map ~f:(fun instr -> instr []) repr in
+ (pos, fst @@ expr, repr)
in
let elifs = List.map ~f:clause elifs
and else_ =
match else_ with
| None -> []
| Some (_, instructions) ->
- List.map ~f:(fun instr -> fst @@ instr []) instructions
+ List.map ~f:(fun instr -> instr []) instructions
in
- (Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }, report)
+ Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }
let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
- fun pos ~label statements report ->
- let label = fst (label [])
- and statements = List.map ~f:(fun instr -> fst @@ instr []) statements in
- (Ast.Act { loc = pos; label; statements }, report)
+ fun pos ~label statements _ ->
+ let label = fst label
+ and statements = List.map ~f:(fun instr -> instr []) statements in
+ Ast.Act { loc = pos; label; statements }
let assign :
S.pos ->
@@ -122,19 +114,23 @@ module Instruction :
T.assignation_operator ->
expression ->
t S.repr =
- fun pos_loc { pos; name; index } op expr report ->
+ fun pos_loc { pos; name; index } op expr _ ->
(*let index = Option.map (fun i -> fst @@ Expression.observe (i [])) index*)
- let index = Option.map (fun f -> fst @@ f []) index in
- let expr = fst (expr []) in
- (Ast.Declaration (pos_loc, { pos; name; index }, op, expr), report)
+ let index = Option.map fst index in
+ let expr = fst expr in
+ Ast.Declaration (pos_loc, { pos; name; index }, op, expr)
end
module Location = struct
- type instruction = S.pos Ast.statement
+ type instruction = (Instruction.t' * Report.t list) S.repr
type t = S.pos * S.pos Ast.statement list
- let location : S.pos -> instruction S.repr list -> t S.repr =
- fun pos block _report ->
- let block = List.map block ~f:(fun b -> fst @@ b []) in
- ((pos, block), [])
+ let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
+ fun pos block report ->
+ let report, block =
+ List.fold_left_map ~init:report block ~f:(fun report b ->
+ let v, report = b report in
+ (report, v))
+ in
+ ((pos, block), report)
end
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 6e28ae0..683a27a 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -142,57 +142,68 @@ module Helper = struct
end
module Expression = struct
- type t = { result : Helper.t; pos : S.pos; empty : bool }
- type t' = t
+ type state = { result : Helper.t; pos : S.pos; empty : bool }
+ type t = state * Report.t list
+ type t' = state
- let v t = t
+ let v : t -> t' * Report.t list = fun t -> t
- let arg_of_repr : t -> Helper.argument_repr =
+ let arg_of_repr : state -> Helper.argument_repr =
fun { result; pos; empty } ->
ignore empty;
{ pos; t = result }
(** The variable has type string when starting with a '$' *)
- let ident : (S.pos, t S.repr) S.variable -> t S.repr =
- fun var report ->
+ let ident : (S.pos, t) S.variable -> t =
+ fun var ->
let empty = false in
+
+ (* Extract the error from the index *)
+ let report =
+ match var.index with
+ | None -> []
+ | Some expr ->
+ let _, r = expr in
+ r
+ in
+
match var.name.[0] with
| '$' -> ({ result = Variable String; pos = var.pos; empty }, report)
| _ -> ({ result = Variable Integer; pos = var.pos; empty }, report)
- let integer : S.pos -> string -> t S.repr =
- fun pos value report ->
+ let integer : S.pos -> string -> t =
+ fun pos value ->
let int_value = int_of_string_opt value in
let empty, report =
match int_value with
- | Some 0 -> (true, report)
- | Some _ -> (false, report)
- | None -> (false, Report.error pos "Invalid integer value" :: report)
+ | Some 0 -> (true, [])
+ | Some _ -> (false, [])
+ | None -> (false, Report.error pos "Invalid integer value" :: [])
in
({ result = Raw Integer; pos; empty }, report)
- let literal : S.pos -> string -> t S.repr =
- fun pos value report ->
+ let literal : S.pos -> string -> t =
+ fun pos value ->
let empty = String.equal String.empty value in
let type_of =
match int_of_string_opt value with
| Some _ -> Helper.NumericString
| None -> Helper.String
in
- ({ result = Raw type_of; pos; empty }, report)
+ ({ result = Raw type_of; pos; empty }, [])
- let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
- fun pos function_ params _acc ->
+ let function_ : S.pos -> T.function_ -> t list -> t =
+ fun pos function_ params ->
(* Accumulate the expressions and get the results, the report is given in
the differents arguments, and we build a list with the type of the
parameters. *)
let types, report =
- List.fold_left params ~init:([], _acc) ~f:(fun (types, report) param ->
- let t, report = param report in
+ List.fold_left params ~init:([], []) ~f:(fun (types, report) param ->
+ let t, r = param in
let arg = arg_of_repr t in
- (arg :: types, report))
+ (arg :: types, r @ report))
in
let types = List.rev types
and default = { result = Variable NumericString; pos; empty = false } in
@@ -275,9 +286,9 @@ module Expression = struct
({ result = Raw Integer; pos; empty = false }, report)
(** Unary operator like [-123] or [+'Text']*)
- let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
- fun pos operator t1 report ->
- let t, report = t1 report in
+ let uoperator : S.pos -> T.uoperator -> t -> t =
+ fun pos operator t1 ->
+ let t, report = t1 in
match operator with
| Add -> (t, report)
| Neg | No ->
@@ -286,11 +297,15 @@ module Expression = struct
let report = Helper.compare_args pos expected types report in
({ result = Raw Integer; pos; empty = false }, report)
- let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
- fun pos operator t1 t2 report ->
- let t1, report = t1 report in
- let t2, report = t2 report in
+ let boperator : S.pos -> T.boperator -> t -> t -> t =
+ fun pos operator t1 t2 ->
+ let t1, report1 = t1 in
+ let t2, report2 = t2 in
+
+ let report = report1 @ report2 in
+
let types = [ arg_of_repr t1; arg_of_repr t2 ] in
+
match operator with
| T.Plus ->
let d = Helper.DynType.t () in
@@ -336,41 +351,43 @@ module Expression = struct
end
module Instruction = struct
- type t = unit
+ type t = Report.t list
type t' = unit
- let v = Fun.id
+ let v : t -> t' * Report.t list = fun local_report -> ((), local_report)
- type expression = Expression.t' S.repr
+ type expression = Expression.t' * Report.t list
(** Call for an instruction like [GT] or [*CLR] *)
let call : S.pos -> T.keywords -> expression list -> t S.repr =
fun _pos _ expressions report ->
- List.fold_left expressions ~init:((), report)
- ~f:(fun ((), report) expression ->
- let result, report = expression report in
- ignore result;
- ((), report))
+ List.fold_left expressions ~init:report ~f:(fun acc a ->
+ let _, report = a in
+ (List.rev_append report) acc)
- let location : S.pos -> string -> t S.repr = fun _pos _ report -> ((), report)
+ let location : S.pos -> string -> t S.repr = fun _pos _ report -> report
(** Comment *)
- let comment : S.pos -> t S.repr = fun _pos report -> ((), report)
+ let comment : S.pos -> t S.repr = fun _pos report -> report
(** Raw expression *)
let expression : expression -> t S.repr =
- fun expression report -> ((), snd (expression report))
+ fun expression report ->
+ ignore report;
+ snd expression
(** Helper function used in the [if_] function. *)
- let fold_clause :
- t * Report.t list -> (expression, t) S.clause -> t * Report.t list =
- fun ((), report) (_pos, expr, instructions) ->
- let result, report = expr report in
- let report =
- Helper.compare Helper.Bool (Expression.arg_of_repr result) report
- in
- List.fold_left instructions ~init:((), report)
- ~f:(fun ((), report) instruction -> instruction report)
+ let fold_clause : t -> (expression, t) S.clause -> t =
+ fun report (_pos, expr, instructions) ->
+ let result, r = expr in
+
+ let r2 = Helper.compare Helper.Bool (Expression.arg_of_repr result) [] in
+
+ List.fold_left instructions
+ ~init:(r @ r2 @ report)
+ ~f:(fun acc a ->
+ let report = a [] in
+ (List.rev_append report) acc)
let if_ :
S.pos ->
@@ -380,23 +397,27 @@ module Instruction = struct
t S.repr =
fun _pos clause ~elifs ~else_ report ->
(* Traverse the whole block recursively *)
- let report = fold_clause ((), report) clause in
+ let report = fold_clause report clause in
let report = List.fold_left elifs ~f:fold_clause ~init:report in
match else_ with
| None -> report
| Some (_, instructions) ->
- List.fold_left instructions ~init:report
- ~f:(fun ((), report) instruction -> instruction report)
+ List.fold_left instructions ~init:report ~f:(fun acc a ->
+ let report = a [] in
+ (List.rev_append report) acc)
let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
fun _pos ~label instructions report ->
- let result, report = label report in
+ let result, r = label in
+ let report = r @ report in
let report =
Helper.compare Helper.String (Expression.arg_of_repr result) report
in
- List.fold_left instructions ~init:((), report)
- ~f:(fun ((), report) instruction -> instruction report)
+
+ List.fold_left instructions ~init:report ~f:(fun acc a ->
+ let report = a [] in
+ (List.rev_append report) acc)
let assign :
S.pos ->
@@ -405,11 +426,12 @@ module Instruction = struct
expression ->
t S.repr =
fun pos variable _ expression report ->
- let right_expression, report = expression report in
+ let right_expression, r = expression in
+ let expr1, report' = Expression.ident variable in
+ let report = report' @ r @ report in
match right_expression.empty with
- | true -> ((), report)
+ | true -> report
| false -> (
- let expr1, report = Expression.ident variable report in
let op1 = Expression.arg_of_repr expr1 in
let op2 = Expression.arg_of_repr right_expression in
@@ -422,21 +444,22 @@ module Instruction = struct
[ op1; op2 ] []
with
| [] ->
- ( (),
- Helper.compare_args ~strict:true ~level:Report.Debug pos expected
- [ op1; op2 ] report )
- | reports -> ((), reports @ report))
+ Helper.compare_args ~strict:true ~level:Report.Debug pos expected
+ [ op1; op2 ] report
+ | reports -> reports @ report)
end
module Location = struct
type t = unit
- type instruction = Instruction.t
+ type instruction = (Instruction.t' * Report.t list) S.repr
- 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 ->
let (), report =
List.fold_left instructions ~init:((), report)
- ~f:(fun ((), report) instruction -> instruction report)
+ ~f:(fun ((), report) instruction ->
+ let _, report' = instruction [] in
+ ((), report' @ report))
in
((), report)
end
diff --git a/test/syntax.ml b/test/syntax.ml
index a420035..56fac8e 100644
--- a/test/syntax.ml
+++ b/test/syntax.ml
@@ -3,7 +3,7 @@ module Ast = Tree.Ast
module Check = Qsp_syntax.Check
module S = Qsp_syntax.S
-let _, _, location_id, e1 = Check.build (module Tree)
+let location_id, e1 = Check.build (module Tree)
module Parser = Check.Make (struct
let t = [| e1 |]
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-18 13:13:29 +0000