aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bin/qsp_parser.ml58
-rw-r--r--lib/qparser/analyzer.ml19
-rw-r--r--lib/qparser/analyzer.mli5
-rw-r--r--lib/qparser/parser.mly4
-rw-r--r--lib/syntax/S.ml13
-rw-r--r--lib/syntax/check.ml60
-rw-r--r--lib/syntax/check.mli3
-rw-r--r--lib/syntax/dead_end.ml8
-rw-r--r--lib/syntax/nested_strings.ml8
-rw-r--r--lib/syntax/tree.ml8
-rw-r--r--lib/syntax/tree.mli1
-rw-r--r--lib/syntax/type_of.ml8
-rw-r--r--test/make_checkTest.ml3
-rw-r--r--test/syntax.ml3
14 files changed, 141 insertions, 60 deletions
diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml
index 6d045b8..fef6aac 100644
--- a/bin/qsp_parser.ml
+++ b/bin/qsp_parser.ml
@@ -83,39 +83,43 @@ let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t =
(module Check))
(** Read the source file until getting a report (the whole location has been
- read properly), or until the first syntax error.
- *)
-let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
- fun ~ctx lexbuf filters ->
- let (module Check) = Lazy.force checkers in
+ read properly), or until the first syntax error.
+
+ The function update the context (list of errors) passed in arguments. *)
+let parse_location :
+ type context.
+ ctx:ctx ref ->
+ (module Qsp_syntax.S.Analyzer with type context = context) ->
+ context ->
+ Qparser.Lexbuf.t ->
+ Args.filters ->
+ unit =
+ fun ~ctx (module Check) context lexbuf filters ->
let result =
- Qparser.Analyzer.parse (module Check) lexbuf
+ Qparser.Analyzer.parse (module Check) lexbuf context
|> Result.map (fun (_, f) ->
List.fold_left f ~init:[] ~f:(filter_report filters)
|> List.sort ~cmp:Report.compare)
in
match result with
- | Ok report -> (
+ | Ok [] -> ()
+ | Ok report ->
(* Display the result *)
- match report with
- | [] -> ctx
- | _ ->
- let start_position, _ = Qparser.Lexbuf.positions lexbuf in
- Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@."
- start_position.Lexing.pos_fname Report.pp_result report;
-
- List.fold_left report ~init:ctx ~f:(fun ctx report ->
- match report.Report.level with
- | Error -> { ctx with error_nb = succ ctx.error_nb }
- | Warn -> { ctx with warn_nb = succ ctx.warn_nb }
- | Debug -> { ctx with debug_nb = succ ctx.debug_nb }))
+ let start_position, _ = Qparser.Lexbuf.positions lexbuf in
+ Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@."
+ start_position.Lexing.pos_fname Report.pp_result report;
+
+ List.iter report ~f:(fun report ->
+ match report.Report.level with
+ | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb }
+ | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb }
+ | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb })
| Error e ->
+ (* Syntax error, we haven’t been able to run the test *)
let start_position, _ = Qparser.Lexbuf.positions lexbuf in
Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@."
start_position.Lexing.pos_fname Report.pp e;
- { ctx with error_nb = succ ctx.error_nb }
-
-let default_ctx = { error_nb = 0; warn_nb = 0; debug_nb = 0 }
+ ctx := { !ctx with error_nb = succ !ctx.error_nb }
let () =
let file_names, parameters =
@@ -142,11 +146,17 @@ let () =
Qparser.Lexbuf.from_lexbuf ~reset_line:parameters.reset_line lexer
in
- let ctx = ref default_ctx in
+ (* Initialize all the checkers before parsing the source *)
+ let (module Check) = Lazy.force checkers in
+ let check_context = Check.initialize () in
+ let ctx = ref { error_nb = 0; warn_nb = 0; debug_nb = 0 } in
+
let () =
try
while true do
- ctx := parse_location ~ctx:!ctx lexer parameters.filters
+ parse_location ~ctx
+ (module Check)
+ check_context lexer parameters.filters
done
with Qparser.Lexer.EOF -> ()
in
diff --git a/lib/qparser/analyzer.ml b/lib/qparser/analyzer.ml
index e3a2774..6d09021 100644
--- a/lib/qparser/analyzer.ml
+++ b/lib/qparser/analyzer.ml
@@ -4,19 +4,25 @@
See [syntax/S]
*)
let parse :
- type a.
- (module Qsp_syntax.S.Analyzer with type Location.t = a) ->
+ type a context.
+ (module Qsp_syntax.S.Analyzer
+ with type Location.t = a
+ and type context = context) ->
Lexbuf.t ->
+ context ->
(a * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) Result.t =
- fun (module S : Qsp_syntax.S.Analyzer with type Location.t = a) ->
+ fun (module S : Qsp_syntax.S.Analyzer
+ with type Location.t = a
+ and type context = context) ->
let module Parser = Parser.Make (S) in
let module IncrementalParser =
Interpreter.Interpreter (Parser.MenhirInterpreter) in
- fun l ->
+ fun l context ->
let lexer = Lexbuf.tokenize Lexer.main l in
let init = Parser.Incremental.main (fst (Lexbuf.positions l)) in
+ (* Firslty, check if we are able to read the whole syntax from the source *)
let evaluation =
try IncrementalParser.of_lexbuf lexer l init with
| Lexer.LexError message ->
@@ -35,8 +41,11 @@ let parse :
Error err
in
+ (* Then apply the checks over the result of the parsing *)
evaluation
- |> Result.map (fun r -> (r, S.Location.v r))
+ |> Result.map (fun r ->
+ let r' = r context in
+ (r', S.Location.v r'))
|> Result.map_error (fun e ->
let message =
match e.IncrementalParser.code with
diff --git a/lib/qparser/analyzer.mli b/lib/qparser/analyzer.mli
index e6dcc14..8033601 100644
--- a/lib/qparser/analyzer.mli
+++ b/lib/qparser/analyzer.mli
@@ -1,6 +1,9 @@
val parse :
- (module Qsp_syntax.S.Analyzer with type Location.t = 'a) ->
+ (module Qsp_syntax.S.Analyzer
+ with type Location.t = 'a
+ and type context = 'context) ->
Lexbuf.t ->
+ 'context ->
('a * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) Result.t
(** Read the source and build a analyzis over it.
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index 861d8b9..9501884 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)>main
+%start <(Analyzer.context -> Analyzer.Location.t)>main
%on_error_reduce expression instruction unary_operator assignation_operator
%%
@@ -31,7 +31,7 @@ main:
LOCATION_END
{
let instructions = List.map instructions ~f:(Analyzer.Instruction.v) in
- Analyzer.Location.location $loc instructions
+ fun context -> Analyzer.Location.location context $loc instructions
}
before_location:
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index afb6526..583249e 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -95,9 +95,10 @@ end
module type Location = sig
type t
type instruction
+ type context
val v : t -> Report.t list
- val location : pos -> instruction list -> t
+ val location : context -> pos -> instruction list -> t
end
(** {1 Unified module used by the parser } *)
@@ -112,9 +113,17 @@ module type Analyzer = sig
val active : bool ref
(** Is the test active or not *)
+ type context
+ (** Context used to keep information during the whole test *)
+
+ val initialize : unit -> context
+ (** Initialize the context before starting to parse the content *)
+
module Expression : Expression
module Instruction : Instruction with type expression = Expression.t'
- module Location : Location with type instruction = Instruction.t'
+
+ module Location :
+ Location with type instruction = Instruction.t' and type context := context
end
(** Helper module used in order to convert elements from the differents
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 6737e80..a5db091 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -55,12 +55,14 @@ type t =
and type Expression.t' = 'b
and type Instruction.t = 'c
and type Instruction.t' = 'd
- and type Location.t = 'e);
+ and type Location.t = 'e
+ and type context = 'f);
expr_witness : 'a Id.typeid;
expr' : 'b Id.typeid;
instr_witness : 'c Id.typeid;
instr' : 'd Id.typeid;
location_witness : 'e Id.typeid;
+ context : 'f Id.typeid;
}
-> t
@@ -70,16 +72,27 @@ let build :
and type Expression.t' = _
and type Instruction.t = _
and type Instruction.t' = _
- and type Location.t = 'a) ->
+ and type Location.t = 'a
+ and type context = _) ->
'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
+ and location_witness = Id.newtype ()
+ and context = Id.newtype () in
let t =
- E { module_; expr_witness; expr'; instr_witness; instr'; location_witness }
+ E
+ {
+ module_;
+ expr_witness;
+ expr';
+ instr_witness;
+ instr';
+ location_witness;
+ context;
+ }
in
(location_witness, t)
@@ -112,6 +125,17 @@ module Make (A : App) = struct
let description = "Internal module"
let active = ref false
+ type context = result Array.t
+ (** We associate each context from the differents test in an array. The
+ context for this module is a sort of context of contexts *)
+
+ (** Initialize each test, and keep the result in the context. *)
+ let initialize : unit -> context =
+ fun () ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); context; _ }) ->
+ let value = S.initialize () in
+ R { value; witness = context })
+
(* Global variable for the whole module *)
let len = Array.length A.t
@@ -127,9 +151,7 @@ module Make (A : App) = struct
List.map values
~f:
(T.map_litteral ~f:(fun expr ->
- match get expr_witness (Array.get expr i) with
- | None -> failwith "Does not match"
- | Some value -> value))
+ Option.get (get expr_witness (Array.get expr i))))
in
let value = S.Expression.literal pos values' in
R { value; witness = expr_witness })
@@ -305,9 +327,7 @@ module Make (A : App) = struct
let index_i =
Option.map
(fun expression ->
- match get expr' (Array.get expression i) with
- | None -> failwith "Does not match"
- | Some value -> value)
+ Option.get (get expr' (Array.get expression i)))
index
in
let variable = S.{ pos = var_pos; name; index = index_i } in
@@ -385,23 +405,31 @@ module Make (A : App) = struct
end
module Location :
- S.Location with type t = result array and type instruction = Instruction.t' =
- struct
+ S.Location
+ with type t = result array
+ and type instruction = Instruction.t'
+ and type context := context = struct
type instruction = Instruction.t'
type t = result array
- let location : S.pos -> instruction list -> t =
- fun pos args ->
+ let location : context -> S.pos -> instruction list -> t =
+ fun local_context pos args ->
ignore pos;
let result =
Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr'; location_witness; _ }) =
+ let (E
+ { module_ = (module A); instr'; location_witness; context; _ })
+ =
Array.get A.t i
in
+ let local_context =
+ Option.get (get context (Array.get local_context i))
+ in
+
let instructions = List.rev (Helper.expr_i args instr' i).values in
- let value = A.Location.location pos instructions in
+ let value = A.Location.location local_context pos instructions in
R { value; witness = location_witness })
in
result
diff --git a/lib/syntax/check.mli b/lib/syntax/check.mli
index daacf47..25075c8 100644
--- a/lib/syntax/check.mli
+++ b/lib/syntax/check.mli
@@ -28,7 +28,8 @@ val build :
and type Expression.t' = _
and type Instruction.t = _
and type Instruction.t' = _
- and type Location.t = 'a) ->
+ and type Location.t = 'a
+ and type context = _) ->
'a Id.typeid * t
(** Build a new check from a module following S.Analyzer signature.
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index 832a97a..ddf7edb 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -4,6 +4,10 @@ let identifier = "dead_end"
let description = "Check for dead end in the code"
let active = ref false
+type context = unit
+
+let initialize = Fun.id
+
module Expression = struct
type t = unit
@@ -148,8 +152,8 @@ module Location = struct
let v = Fun.id
- let location : S.pos -> instruction list -> t =
- fun _pos instructions ->
+ let location : unit -> 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) ->
diff --git a/lib/syntax/nested_strings.ml b/lib/syntax/nested_strings.ml
index 4dd5c81..0119197 100644
--- a/lib/syntax/nested_strings.ml
+++ b/lib/syntax/nested_strings.ml
@@ -4,6 +4,10 @@ let identifier = "escaped_string"
let description = "Check for unnecessary use of expression encoded in string"
let active = ref true
+type context = unit
+
+let initialize = Fun.id
+
module TypeBuilder = Compose.Expression (Get_type)
module Expression = TypeBuilder.Make (struct
@@ -143,8 +147,8 @@ module Location = struct
let v = Fun.id
- let location : S.pos -> instruction list -> t =
- fun pos intructions ->
+ let location : unit -> S.pos -> instruction list -> t =
+ fun () pos intructions ->
ignore pos;
List.concat intructions
end
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index 21238a6..6f6e7f2 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -4,6 +4,10 @@ let identifier = "tree"
let description = "Build the AST"
let active = ref true
+type context = unit
+
+let initialize = Fun.id
+
module Ast = struct
type 'a literal = 'a T.literal = Text of string | Expression of 'a
[@@deriving eq, show]
@@ -120,5 +124,7 @@ module Location = struct
type t = S.pos * S.pos Ast.statement list
let v _ = []
- let location : S.pos -> instruction list -> t = fun pos block -> (pos, block)
+
+ let location : unit -> S.pos -> instruction list -> t =
+ fun () pos block -> (pos, block)
end
diff --git a/lib/syntax/tree.mli b/lib/syntax/tree.mli
index c5506e7..8ce577e 100644
--- a/lib/syntax/tree.mli
+++ b/lib/syntax/tree.mli
@@ -48,3 +48,4 @@ include
with type Expression.t' = S.pos Ast.expression
and type Instruction.t' = S.pos Ast.statement
and type Location.t = S.pos * S.pos Ast.statement list
+ and type context = unit
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 239717c..fcce565 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -4,6 +4,10 @@ let identifier = "type_check"
let description = "Ensure all the expression are correctly typed"
let active = ref true
+type context = unit
+
+let initialize = Fun.id
+
module Helper = struct
type argument_repr = { pos : S.pos; t : Get_type.t }
@@ -474,8 +478,8 @@ module Location = struct
let v = Fun.id
- let location : S.pos -> instruction list -> t =
- fun _pos instructions ->
+ let location : unit -> S.pos -> instruction list -> t =
+ fun () _pos instructions ->
let report =
List.fold_left instructions ~init:[] ~f:(fun report instruction ->
let report' = instruction in
diff --git a/test/make_checkTest.ml b/test/make_checkTest.ml
index 2066c22..d428b45 100644
--- a/test/make_checkTest.ml
+++ b/test/make_checkTest.ml
@@ -26,7 +26,8 @@ module M (Check : Qsp_syntax.S.Analyzer) = struct
let lexing =
Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
in
- Qparser.Analyzer.parse (module Check) lexing
+ let context = Check.initialize () in
+ Qparser.Analyzer.parse (module Check) lexing context
let get_report :
(Check.Location.t * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result ->
diff --git a/test/syntax.ml b/test/syntax.ml
index 47f1a25..87fe2ab 100644
--- a/test/syntax.ml
+++ b/test/syntax.ml
@@ -27,7 +27,8 @@ let parse : string -> (S.pos location, Qsp_syntax.Report.t) result =
let lexing =
Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
in
- Qparser.Analyzer.parse (module Parser) lexing
+ let context = Parser.initialize () in
+ Qparser.Analyzer.parse (module Parser) lexing context
|> Result.map (fun (location, _report) ->
(* Uncatched excteptions here, but we are in the tests…
If it’s fail here I have an error in the code. *)
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-18 10:01:37 +0000