From 180529c30282d39f3506633716e3fe439db03309 Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Fri, 3 Nov 2023 10:19:29 +0100
Subject: Extracting the report from the Location checker is now in it’s own
function
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
---
lib/qparser/analyzer.ml | 1 +
lib/qparser/parser.mly | 2 +-
lib/syntax/S.ml | 3 ++-
lib/syntax/check.ml | 24 +++++++++++++++++++-----
lib/syntax/dead_end.ml | 35 ++++++++++++++++++-----------------
lib/syntax/nested_strings.ml | 8 +++++---
lib/syntax/tree.ml | 4 ++--
lib/syntax/type_of.ml | 8 +++++---
8 files changed, 53 insertions(+), 32 deletions(-)
diff --git a/lib/qparser/analyzer.ml b/lib/qparser/analyzer.ml
index a79535e..e3a2774 100644
--- a/lib/qparser/analyzer.ml
+++ b/lib/qparser/analyzer.ml
@@ -36,6 +36,7 @@ let parse :
in
evaluation
+ |> Result.map (fun r -> (r, S.Location.v r))
|> Result.map_error (fun e ->
let message =
match e.IncrementalParser.code with
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index 81b630a..73d77b7 100644
--- a/lib/qparser/parser.mly
+++ b/lib/qparser/parser.mly
@@ -18,7 +18,7 @@
%}
%parameter<Analyzer: Qsp_syntax.S.Analyzer>
-%start <(Analyzer.Location.t * Qsp_syntax.Report.t list)>main
+%start <(Analyzer.Location.t)>main
%on_error_reduce expression instruction unary_operator assignation_operator
%%
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index f7c3ebe..972e405 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -96,7 +96,8 @@ module type Location = sig
type t
type instruction
- val location : pos -> instruction list -> t * Report.t list
+ val v : t -> Report.t list
+ val location : pos -> instruction list -> t
end
(** {1 Unified module used by the parser } *)
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 2528914..a7095fc 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -394,11 +394,10 @@ module Make (A : App) = struct
type instruction = Instruction.t'
type t = result array
- let location : S.pos -> instruction list -> t * Report.t list =
+ let location : S.pos -> instruction list -> t =
fun pos args ->
ignore pos;
- let report = ref [] in
let result =
Array.init len ~f:(fun i ->
let (E { module_ = (module A); instr'; location_witness; _ }) =
@@ -406,10 +405,25 @@ module Make (A : App) = struct
in
let instructions = List.rev (Helper.expr_i args instr' i).values in
- let value, re = A.Location.location pos instructions in
- report := List.rev_append re !report;
+ let value = A.Location.location pos instructions in
R { value; witness = location_witness })
in
- (result, !report)
+ result
+
+ let v : t -> Report.t list =
+ fun args ->
+ let report = ref [] in
+ let () =
+ Array.iteri args ~f:(fun i result ->
+ let (E { module_ = (module A); location_witness; _ }) =
+ Array.get A.t i
+ in
+ match get location_witness result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let re = A.Location.v value in
+ report := List.rev_append re !report)
+ in
+ !report
end
end
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index 1240e72..042e640 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -140,24 +140,25 @@ module Instruction = struct
end
module Location = struct
- type t = unit
+ type t = Report.t list
type instruction = Instruction.t'
- let location : S.pos -> instruction list -> t * Report.t list =
+ let v = Fun.id
+
+ let location : S.pos -> instruction list -> t =
fun _pos instructions ->
- ( (),
- List.fold_left instructions ~init:[] ~f:(fun report t ->
- match (t.Instruction.is_gt, t.Instruction.pos) with
- | false, Some (cause, value) ->
- ignore cause;
- if t.Instruction.block_pos != value then
- match cause with
- | Missing_else ->
- Report.debug value "Possible dead end (no else fallback)"
- :: report
- | Unchecked_path ->
- Report.warn value "Possible dead end (unmatched path)"
- :: report
- else report
- | _ -> report) )
+ List.fold_left instructions ~init:[] ~f:(fun report t ->
+ match (t.Instruction.is_gt, t.Instruction.pos) with
+ | false, Some (cause, value) ->
+ ignore cause;
+ if t.Instruction.block_pos != value then
+ match cause with
+ | Missing_else ->
+ Report.debug value "Possible dead end (no else fallback)"
+ :: report
+ | Unchecked_path ->
+ Report.warn value "Possible dead end (unmatched path)"
+ :: report
+ else report
+ | _ -> report)
end
diff --git a/lib/syntax/nested_strings.ml b/lib/syntax/nested_strings.ml
index fb056d6..9d4867c 100644
--- a/lib/syntax/nested_strings.ml
+++ b/lib/syntax/nested_strings.ml
@@ -99,11 +99,13 @@ struct
end
module Location = struct
- type t = unit
+ type t = Report.t list
type instruction = Instruction.t'
- let location : S.pos -> instruction list -> t * Report.t list =
+ let v = Fun.id
+
+ let location : S.pos -> instruction list -> t =
fun pos intructions ->
ignore pos;
- ((), List.concat intructions)
+ List.concat intructions
end
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index 34baae0..e70b66a 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -115,6 +115,6 @@ module Location = struct
type instruction = Instruction.t'
type t = S.pos * S.pos Ast.statement list
- let location : S.pos -> instruction list -> t * Report.t list =
- fun pos block -> ((pos, block), [])
+ let v _ = []
+ let location : S.pos -> instruction list -> t = fun pos block -> (pos, block)
end
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index ce04872..8f1c7ef 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -465,15 +465,17 @@ module Instruction = struct
end
module Location = struct
- type t = unit
+ type t = Report.t list
type instruction = Instruction.t'
- let location : S.pos -> instruction list -> t * Report.t list =
+ let v = Fun.id
+
+ let location : S.pos -> instruction list -> t =
fun _pos instructions ->
let report =
List.fold_left instructions ~init:[] ~f:(fun report instruction ->
let report' = instruction in
report' @ report)
in
- ((), report)
+ report
end
--
cgit v1.2.3