aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-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
11 files changed, 103 insertions, 34 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-18 12:55:30 +0000