From 6fd720c07e3e361932e01bfbdbe4637c8f610649 Mon Sep 17 00:00:00 2001 From: Chimrod <> Date: Sun, 4 Feb 2024 10:37:04 +0100 Subject: Added a general context for each test --- lib/syntax/S.ml | 13 ++++++++-- lib/syntax/check.ml | 60 ++++++++++++++++++++++++++++++++------------ lib/syntax/check.mli | 3 ++- lib/syntax/dead_end.ml | 8 ++++-- lib/syntax/nested_strings.ml | 8 ++++-- lib/syntax/tree.ml | 8 +++++- lib/syntax/tree.mli | 1 + lib/syntax/type_of.ml | 8 ++++-- 8 files changed, 83 insertions(+), 26 deletions(-) (limited to 'lib/syntax') 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 -- cgit v1.2.3