From 75f3eabb46eded01460f7700a75d094100047438 Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Sat, 14 Dec 2024 23:06:12 +0100
Subject: Added dynamic check mecanism
---
bin/qsp_parser.ml | 132 ++++++++++++++++------
lib/checks/check.mli | 5 +-
lib/checks/compose.ml | 7 +-
lib/checks/default.ml | 84 ++++++++++++--
lib/checks/dune | 4 +-
lib/checks/dup_test.ml | 66 +++++------
lib/checks/dynamics.ml | 262 +++++++++++++++++++++++++++++++++++++++++++
lib/checks/dynamics.mli | 5 +
lib/checks/locations.ml | 51 +++------
lib/checks/nested_strings.ml | 6 +-
lib/checks/type_of.ml | 16 ++-
lib/checks/write_only.ml | 12 +-
lib/qparser/analyzer.ml | 36 ++++--
lib/qparser/analyzer.mli | 8 +-
lib/qparser/lexbuf.ml | 6 +-
lib/qparser/lexbuf.mli | 37 +++---
lib/qparser/lexer.ml | 22 ++--
lib/qparser/lexer.mli | 2 +
lib/qparser/parser.mly | 19 +++-
lib/qparser/tokens.mly | 1 +
lib/syntax/S.ml | 11 +-
lib/syntax/catalog.ml | 36 +++---
lib/syntax/catalog.mli | 6 +-
lib/syntax/dune | 4 +-
readme.md | 2 +-
test/dup_cases.ml | 10 +-
test/dynamics.ml | 93 +++++++++++++++
test/literals.ml | 15 +++
test/location.ml | 10 ++
test/make_checkTest.ml | 24 ++--
test/qsp_parser_test.ml | 1 +
test/syntax.ml | 7 +-
32 files changed, 763 insertions(+), 237 deletions(-)
create mode 100644 lib/checks/dynamics.ml
create mode 100644 lib/checks/dynamics.mli
create mode 100644 test/dynamics.ml
diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml
index a8ee457..f928d24 100644
--- a/bin/qsp_parser.ml
+++ b/bin/qsp_parser.ml
@@ -14,17 +14,27 @@ let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list =
type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool }
+module type T = sig
+ include module type of Qsp_checks.Dynamics
+end
+
+(** Witness used to extract the values in the module Qsp_checks.Dynamics during
+ the parsing. *)
+let dynamic_context_id : Qsp_checks.Dynamics.context Type.Id.t = Type.Id.make ()
+
(*
List all the controls to apply
*)
let available_checks =
[
- snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Type_of);
- snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end);
- snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings);
- snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Locations);
- snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test);
- snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Write_only);
+ Qsp_syntax.Catalog.build ~context_id:dynamic_context_id
+ (module Qsp_checks.Dynamics);
+ Qsp_syntax.Catalog.build (module Qsp_checks.Type_of);
+ Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end);
+ Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings);
+ Qsp_syntax.Catalog.build (module Qsp_checks.Locations);
+ Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test);
+ Qsp_syntax.Catalog.build (module Qsp_checks.Write_only);
]
let pp_module formatter (module A : Qsp_syntax.S.Analyzer) =
@@ -72,7 +82,10 @@ let pp_modules formatter =
The expression is declared lazy in order to be sure to apply the filters
from the command line before. *)
-let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t =
+let checkers :
+ (module Qsp_syntax.S.Analyzer
+ with type context = Qsp_checks.Check.result array)
+ Lazy.t =
lazy
(let module Check = Qsp_checks.Check.Make (struct
let t =
@@ -85,44 +98,94 @@ let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t =
end) in
(module Check))
+let display_result :
+ ctx:ctx ref ->
+ Qparser.Lexbuf.t ->
+ Args.filters ->
+ (Report.t list, Report.t) result ->
+ unit =
+ fun ~ctx lexbuf filters result ->
+ match result with
+ | 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 := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true }
+ | Ok report -> (
+ let report =
+ List.fold_left report ~init:[] ~f:(filter_report filters)
+ |> List.sort ~cmp:Report.compare
+ in
+ match report with
+ | [] -> ()
+ | _ ->
+ (* Display the result *)
+ 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 }))
+
(** Read the source file until getting a report (the whole location has been
read properly), or until the first syntax error.
The function update the context (list of errors) passed in arguments. *)
-let parse_location : type context.
+let parse_location :
ctx:ctx ref ->
- (module Qsp_syntax.S.Analyzer with type context = context) ->
- context ->
+ (module Qsp_syntax.S.Analyzer
+ with type context = Qsp_checks.Check.result array) ->
+ Qsp_checks.Check.result array ->
Qparser.Lexbuf.t ->
Args.filters ->
unit =
fun ~ctx (module Check) context lexbuf filters ->
let result =
- Qparser.Analyzer.parse (module Check) lexbuf context
- |> Result.map (fun f ->
- List.fold_left f.Qparser.Analyzer.report ~init:[]
- ~f:(filter_report filters)
- |> List.sort ~cmp:Report.compare)
+ Qparser.Analyzer.parse
+ (module Check)
+ Qparser.Analyzer.Location lexbuf context
in
- match result with
- | Ok [] -> ()
- | Ok report ->
- (* Display the result *)
- 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 := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true }
+ (* Also analyse eache dynamic string identified in the module *)
+ let result_with_dynamics =
+ Result.map
+ (fun r ->
+ match Qsp_checks.Check.get dynamic_context_id (Array.get context 0) with
+ | None -> r.Qparser.Analyzer.report
+ | Some dyn_context ->
+ let seq : Qsp_checks.Dynamics.text Seq.t =
+ Qsp_checks.Dynamics.dynamics_string dyn_context
+ in
+ Seq.fold_left
+ (fun r content ->
+ let text = content.Qsp_checks.Dynamics.content ^ "\n" in
+
+ let lexing =
+ Sedlexing.Latin1.from_string text
+ |> Qparser.Lexbuf.from_lexbuf
+ ~position:(fst content.Qsp_checks.Dynamics.position)
+ in
+
+ let dyn_report =
+ Qparser.Analyzer.parse
+ (module Check)
+ Qparser.Analyzer.Dynamic lexing context
+ in
+ match dyn_report with
+ | Error e ->
+ (* Syntax error are not blocking here, but are transformed
+ into check error *)
+ e :: r
+ | Ok dyn_ok_reports ->
+ dyn_ok_reports.Qparser.Analyzer.report @ r)
+ r.Qparser.Analyzer.report seq)
+ result
+ in
+ display_result ~ctx lexbuf filters result_with_dynamics
let () =
let file_names, parameters =
@@ -144,6 +207,9 @@ let () =
Qsp_checks.Check.get_module t
in
if C.is_global && !C.active then C.active := false);
+
+ Qsp_checks.Dynamics.active := true;
+
(* The source file are in UTF-8, and we can use the file line number as
we have only a single location. *)
( Sedlexing.Utf8.from_channel ic,
diff --git a/lib/checks/check.mli b/lib/checks/check.mli
index 8502753..ebed0df 100644
--- a/lib/checks/check.mli
+++ b/lib/checks/check.mli
@@ -24,6 +24,9 @@ val get : 'a Type.Id.t -> result -> 'a option
module Make (A : sig
val t : Qsp_syntax.Catalog.ex array
end) : sig
- include Qsp_syntax.S.Analyzer with type Location.t = result array
+ include
+ Qsp_syntax.S.Analyzer
+ with type Location.t = result array
+ and type context = result array
end
[@@warning "-67"]
diff --git a/lib/checks/compose.ml b/lib/checks/compose.ml
index 4517755..b29c22e 100644
--- a/lib/checks/compose.ml
+++ b/lib/checks/compose.ml
@@ -41,8 +41,8 @@ module Lazier (E : S.Expression) :
end
(** Build an expression module with the result from another expression. The
- signature of the fuctions is a bit different, as they all receive the
- result from the previous evaluated element in argument. *)
+ signature of the fuctions is a bit different, as they all receive the result
+ from the previous evaluated element in argument. *)
module Expression (E : S.Expression) = struct
module type SIG = sig
type t
@@ -125,3 +125,6 @@ module Expression (E : S.Expression) = struct
(t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t'))
end
end
+
+module TypeBuilder = Expression (Get_type)
+(** Builder adding the type for the expression *)
diff --git a/lib/checks/default.ml b/lib/checks/default.ml
index a2b53f6..0c4d761 100644
--- a/lib/checks/default.ml
+++ b/lib/checks/default.ml
@@ -1,25 +1,23 @@
-(** Default implementation which does nothing.
+(** Default implementation which does nothing.
-This module is expected to be used when you only need to implement an analyze
-over a limited part of the whole syntax. *)
+ This module is expected to be used when you only need to implement an
+ analyze over a limited part of the whole syntax. *)
+open StdLabels
module S = Qsp_syntax.S
module T = Qsp_syntax.T
module Report = Qsp_syntax.Report
-module type T = sig
+module Expression (T' : sig
type t
val default : t
-end
-
-module Expression (T' : T) = struct
- (**
- Describe a variable, using the name in capitalized text, and an optionnal
+end) =
+struct
+ (** Describe a variable, using the name in capitalized text, and an optionnal
index.
- If missing, the index should be considered as [0].
- *)
+ If missing, the index should be considered as [0]. *)
type t' = T'.t
@@ -43,3 +41,67 @@ module Expression (T' : T) = struct
let boperator : S.pos -> T.boperator -> T'.t -> T'.t -> T'.t =
fun _ _ _ _ -> T'.default
end
+
+module Instruction (Expression : sig
+ type t'
+end) (T : sig
+ type t
+
+ val default : t
+ val fold : t Seq.t -> t
+end) =
+struct
+ let call : S.pos -> Qsp_syntax.T.keywords -> Expression.t' list -> T.t =
+ fun _ _ _ -> T.default
+
+ let location : S.pos -> string -> T.t =
+ fun position name ->
+ ignore position;
+ ignore name;
+ T.default
+
+ let comment : S.pos -> T.t =
+ fun position ->
+ ignore position;
+ T.default
+
+ let expression : Expression.t' -> T.t =
+ fun expr ->
+ ignore expr;
+ T.default
+
+ let map_clause : (Expression.t', T.t) S.clause -> T.t Seq.t =
+ fun (_, _, els) -> List.to_seq els
+
+ let if_ :
+ S.pos ->
+ (Expression.t', T.t) S.clause ->
+ elifs:(Expression.t', T.t) S.clause list ->
+ else_:(S.pos * T.t list) option ->
+ T.t =
+ fun pos clause ~elifs ~else_ ->
+ ignore pos;
+
+ let seq = List.to_seq (clause :: elifs) |> Seq.flat_map map_clause in
+
+ let seq =
+ match else_ with
+ | None -> seq
+ | Some (_, ts) -> Seq.append seq (List.to_seq ts)
+ in
+ T.fold seq
+
+ let act : S.pos -> label:Expression.t' -> T.t list -> T.t =
+ fun pos ~label instructions ->
+ ignore pos;
+ ignore label;
+ T.fold (List.to_seq instructions)
+
+ let assign :
+ S.pos ->
+ (S.pos, Expression.t') S.variable ->
+ Qsp_syntax.T.assignation_operator ->
+ Expression.t' ->
+ T.t =
+ fun _ _ _ _ -> T.default
+end
diff --git a/lib/checks/dune b/lib/checks/dune
index d7db2f3..3bd22e0 100644
--- a/lib/checks/dune
+++ b/lib/checks/dune
@@ -5,5 +5,7 @@
)
(preprocess (pps
- ppx_deriving.show ppx_deriving.enum
+ ppx_deriving.show
+ ppx_deriving.enum
+ ppx_deriving.ord
ppx_deriving.eq )))
diff --git a/lib/checks/dup_test.ml b/lib/checks/dup_test.ml
index 9ffe7c5..c29eca9 100644
--- a/lib/checks/dup_test.ml
+++ b/lib/checks/dup_test.ml
@@ -1,9 +1,7 @@
(** This module check for duplicated tests in the source.contents
-
- This in intended to identify the copy/paste errors, where one location
- check for the same arguments twice or more.
- *)
+ This in intended to identify the copy/paste errors, where one location check
+ for the same arguments twice or more. *)
open StdLabels
module S = Qsp_syntax.S
@@ -23,8 +21,8 @@ let finalize () = []
module Expression = Tree.Expression
-(** Build a Hashtbl over the expression, ignoring the location in the
- expression *)
+(** Build a Hashtbl over the expression, ignoring the location in the expression
+*)
module Table = Hashtbl.Make (struct
type t = Expression.t'
@@ -37,23 +35,33 @@ module Instruction = struct
predicates : (Expression.t' * S.pos) list;
duplicates : (Expression.t' * S.pos list) list;
}
- (** Keep the list of all the predicates and their position in a block, and
- the list of all the identified duplicated values. *)
+ (** Keep the list of all the predicates and their position in a block, and the
+ list of all the identified duplicated values. *)
type t = state
type t' = state
- let v : t -> t' = fun t -> t
let default = { predicates = []; duplicates = [] }
- (** Label for a loop *)
- let location : S.pos -> string -> t = fun _ _ -> default
+ include
+ Default.Instruction
+ (Expression)
+ (struct
+ type nonrec t = t
- (** Comment *)
- let comment : S.pos -> t = fun _ -> default
+ let default = default
- (** Raw expression *)
- let expression : Expression.t' -> t = fun _ -> default
+ let fold sequence =
+ Seq.fold_left
+ (fun state ex ->
+ {
+ predicates = [];
+ duplicates = List.rev_append ex.duplicates state.duplicates;
+ })
+ default sequence
+ end)
+
+ let v : t -> t' = fun t -> t
let check_duplicates :
(Expression.t' * S.pos) list -> (Expression.t' * S.pos list) list =
@@ -74,10 +82,9 @@ module Instruction = struct
| other -> Some (hd, other)))
|> List.of_seq
- (** Evaluate a clause.
- This function does two things :
- - report all errors from the bottom to top
- - add the clause in the actual level *)
+ (** Evaluate a clause. This function does two things :
+ - report all errors from the bottom to top
+ - add the clause in the actual level *)
let predicate_of_clause : ?pos:S.pos -> t -> (Expression.t', t) S.clause -> t
=
fun ?pos t (pos2, predicate, blocks) ->
@@ -118,27 +125,6 @@ module Instruction = struct
state with
duplicates = check_duplicates state.predicates @ state.duplicates;
}
-
- let act : S.pos -> label:Expression.t' -> t list -> t =
- fun _pos ~label expressions ->
- ignore label;
- (* Collect all the elements reported from bottom to up. *)
- List.fold_left ~init:default expressions ~f:(fun state ex ->
- {
- predicates = [];
- duplicates = List.rev_append ex.duplicates state.duplicates;
- })
-
- let assign :
- S.pos ->
- (S.pos, Expression.t') S.variable ->
- T.assignation_operator ->
- Expression.t' ->
- t =
- fun _ _ _ _ -> default
-
- let call : S.pos -> T.keywords -> Expression.t' list -> t =
- fun _ _ _ -> default
end
module Location = struct
diff --git a/lib/checks/dynamics.ml b/lib/checks/dynamics.ml
new file mode 100644
index 0000000..0c16ff8
--- /dev/null
+++ b/lib/checks/dynamics.ml
@@ -0,0 +1,262 @@
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+let identifier = "dynamics"
+let description = "Report all dynamics string in the module"
+let is_global = true
+let active = ref false
+
+type text = { content : string; position : S.pos } [@@deriving eq, ord]
+
+module StringSet = Set.Make (struct
+ type t = text [@@deriving ord]
+end)
+
+type context = StringSet.t ref
+
+let initialize () = ref StringSet.empty
+
+module Expression = struct
+ (** Elements wich can be given to dynamic.
+
+ For Text, I do not evaluate text containing expression. This need to be a
+ plain text.
+
+ In the case of variable, indexes will probably not work if they include
+ function or complex expression *)
+ type t = None | Text of text | Variable of (unit, t) S.variable
+ [@@deriving eq, ord]
+
+ (** Remove all the locations inside a variable in order to be able to compare
+ two of them at differents locations *)
+ let rec anonymize_variable : (unit, t) S.variable -> (unit, t) S.variable =
+ fun ({ index; _ } as variable) ->
+ let index =
+ Option.map
+ (function
+ | None -> None
+ | Text { content; _ } ->
+ let position = (Lexing.dummy_pos, Lexing.dummy_pos) in
+ Text { content; position }
+ | Variable var -> Variable (anonymize_variable var))
+ index
+ in
+ { variable with index }
+
+ include Default.Expression (struct
+ type nonrec t = t
+
+ let default = None
+ end)
+
+ let v : t -> t' = Fun.id
+
+ (** Only keep the raw strings *)
+ let literal : S.pos -> t T.literal list -> t =
+ fun position content ->
+ ignore position;
+ match content with
+ | [ T.Text content ] -> Text { content; position }
+ | _ -> (
+ (* Here I analyse if the expression is a string or
+ numeric. In case of numeric, it is possible to replace it with a
+ default value *)
+ let buffer = Buffer.create 16 in
+ let res =
+ List.fold_left ~init:`Ok content ~f:(fun state literal ->
+ match (state, literal) with
+ | `None, _ -> `None
+ | `Ok, T.Expression None -> `None
+ | `Ok, T.Expression (Text content) ->
+ Buffer.add_string buffer content.content;
+ `Ok
+ | `Ok, T.Text content ->
+ Buffer.add_string buffer content;
+ `Ok
+ | `Ok, T.Expression (Variable { name; _ }) ->
+ let res =
+ if Char.equal '$' name.[0] then `None
+ else (
+ Buffer.add_char buffer '0';
+ `Ok)
+ in
+ res)
+ in
+ match res with
+ | `Ok -> Text { content = Buffer.contents buffer; position }
+ | _ -> None)
+
+ (** Consider the integer as text. This is easier for evaluating the indices in
+ the arrays (it use the same code as text indices), and will report bad use
+ of dynamics. *)
+ let integer : S.pos -> string -> t =
+ fun position content -> Text { content; position }
+
+ (** If the identifier uses any unmanaged expression in the indices, ignore it.
+ *)
+ let ident : (S.pos, t) S.variable -> t =
+ fun ({ index; _ } as ident) ->
+ let is_valid =
+ Option.fold ~none:true index ~some:(fun opt ->
+ match opt with None -> false | _ -> true)
+ in
+ match is_valid with
+ | false -> None
+ | true -> Variable (anonymize_variable { ident with pos = () })
+end
+
+module Instruction = struct
+ (** This map holds the values for each variable seen in the code *)
+ module StringMap = struct
+ include Hashtbl.Make (struct
+ type t = (unit, Expression.t) S.variable [@@deriving eq]
+
+ let hash = Hashtbl.hash
+ end)
+
+ (** Recursive search in the table *)
+ let rec_find :
+ Expression.t' t -> (unit, Expression.t) S.variable -> StringSet.t =
+ fun table key ->
+ let rec _f init key =
+ let values = find_all table key in
+ List.fold_left values ~init ~f:(fun acc value ->
+ match value with
+ | Expression.None -> acc
+ | Expression.Text text -> StringSet.add text acc
+ | Expression.Variable variable -> _f acc variable)
+ in
+ _f StringSet.empty key
+ end
+
+ module VariableSet = Set.Make (struct
+ type t = (unit, Expression.t) S.variable [@@deriving ord]
+ end)
+
+ type context = {
+ catalog : Expression.t' StringMap.t;
+ texts : StringSet.t;
+ blacklist : VariableSet.t;
+ variable_called : VariableSet.t;
+ }
+ (** Keep the content of each string in order to parse it later *)
+
+ (** This module do two things : keep a track of the raw strings in the
+ location, and identify the calls to the function dynamic.
+
+ The dynamic parameter are reported as is, and are evaluated only at the
+ end of the module. *)
+
+ type t = context -> context
+ type t' = t
+
+ let v = Fun.id
+
+ include
+ Default.Instruction
+ (Expression)
+ (struct
+ type nonrec t = t
+
+ let fold : t Seq.t -> t =
+ fun seq init_context ->
+ let result =
+ Seq.fold_left
+ (fun context (instr : t) -> instr context)
+ init_context seq
+ in
+ result
+
+ let default context = context
+ end)
+
+ (** Keep the track of dynamic instructions *)
+ let call : S.pos -> T.keywords -> Expression.t' list -> t =
+ fun position keyword arg context ->
+ ignore position;
+ ignore arg;
+ match keyword with
+ | T.Dynamic -> (
+ match arg with
+ | [ Expression.Text text ] ->
+ let texts = StringSet.add text context.texts in
+
+ { context with texts }
+ | [ Expression.Variable var ] ->
+ let variable_called = VariableSet.add var context.variable_called in
+ { context with variable_called }
+ | _ -> context)
+ | _ -> context
+
+ let assign :
+ S.pos ->
+ (S.pos, Expression.t') S.variable ->
+ T.assignation_operator ->
+ Expression.t' ->
+ t =
+ fun pos variable op expression context ->
+ ignore pos;
+ let variable' = Expression.anonymize_variable { variable with pos = () } in
+ let is_blacklisted = VariableSet.mem variable' context.blacklist in
+ let is_string = variable.name.[0] = '$' in
+ match (op, expression, is_blacklisted, is_string) with
+ | T.Eq', Expression.Text content, false, true
+ when not (String.equal content.content "") ->
+ StringMap.add context.catalog variable' expression;
+ context
+ | T.Eq', Expression.Variable _, false, _ ->
+ StringMap.add context.catalog variable' expression;
+ context
+ | _ ->
+ (* If the assignation is not direct, we **remove** all the bindings
+ from the catalog. *)
+ StringMap.find_all context.catalog variable'
+ |> List.iter ~f:(fun _ -> StringMap.remove context.catalog variable');
+
+ (* We also black list this variable and prevent further additions *)
+ let blacklist = VariableSet.add variable' context.blacklist in
+ { context with blacklist }
+end
+
+module Location = struct
+ type t = unit
+ type instruction = Instruction.t'
+
+ let location : context -> S.pos -> instruction list -> t =
+ fun context pos instr ->
+ ignore pos;
+ let catalog = Instruction.StringMap.create 16 in
+ let init =
+ Instruction.
+ {
+ catalog;
+ texts = !context;
+ blacklist = VariableSet.empty;
+ variable_called = VariableSet.empty;
+ }
+ in
+ let res = List.fold_left instr ~init ~f:(fun acc instr -> instr acc) in
+
+ (* Now, for each dynamics calling a variable, looks in the catalog if we
+ can find the associated string *)
+ let texts =
+ Instruction.VariableSet.fold
+ (fun variable acc ->
+ let indirects = Instruction.StringMap.rec_find res.catalog variable in
+
+ StringSet.union acc indirects)
+ res.variable_called res.texts
+ in
+ context := texts
+
+ let v : t -> Report.t list = fun _ -> []
+end
+
+let finalize context =
+ ignore context;
+ []
+
+let dynamics_string : context -> text Seq.t =
+ fun context -> StringSet.to_seq !context
diff --git a/lib/checks/dynamics.mli b/lib/checks/dynamics.mli
new file mode 100644
index 0000000..b4cdc96
--- /dev/null
+++ b/lib/checks/dynamics.mli
@@ -0,0 +1,5 @@
+include Qsp_syntax.S.Analyzer
+
+type text = { content : string; position : Qsp_syntax.S.pos }
+
+val dynamics_string : context -> text Seq.t
diff --git a/lib/checks/locations.ml b/lib/checks/locations.ml
index 8ee6ffa..8e5f500 100644
--- a/lib/checks/locations.ml
+++ b/lib/checks/locations.ml
@@ -74,7 +74,7 @@ let registerLocation : string -> t -> t =
{ calls; locations }
(** The module Expression is pretty simple, we are only interrested by the
- strings ( because only the first argument of [gt …] is read ).
+ strings ( because only the first argument of [gt …] is read ).
If the string is too much complex, we just ignore it. *)
module Expression = struct
@@ -99,6 +99,18 @@ module Instruction = struct
let v : t -> t' = Fun.id
+ include
+ Default.Instruction
+ (Expression)
+ (struct
+ type nonrec t = t
+
+ let default = Fun.id
+
+ let fold : t Seq.t -> t =
+ fun sequence t -> Seq.fold_left (fun acc t -> t acc) t sequence
+ end)
+
(** Keep a track of every gt or gs instruction *)
let call : S.pos -> T.keywords -> Expression.t' list -> t =
fun pos fn args t ->
@@ -106,43 +118,6 @@ module Instruction = struct
| T.Goto, Some dest :: _ -> registerCall pos dest t
| T.Gosub, Some dest :: _ -> registerCall pos dest t
| _ -> t
-
- let location : S.pos -> string -> t = fun _ _ -> Fun.id
- let comment : S.pos -> t = fun _ -> Fun.id
- let expression : Expression.t' -> t = fun _ -> Fun.id
-
- let if_ :
- S.pos ->
- (Expression.t', t) S.clause ->
- elifs:(Expression.t', t) S.clause list ->
- else_:(S.pos * t list) option ->
- t =
- fun _ clause ~elifs ~else_ t ->
- let traverse_clause t clause =
- let _, _, block = clause in
- List.fold_left block ~init:t ~f:(fun t instruction -> instruction t)
- in
-
- let t = traverse_clause t clause in
- let t = List.fold_left ~init:t ~f:traverse_clause elifs in
- match else_ with
- | None -> t
- | Some (_, instructions) ->
- List.fold_left instructions ~init:t ~f:(fun t instruction ->
- instruction t)
-
- let act : S.pos -> label:Expression.t' -> t list -> t =
- fun _ ~label instructions t ->
- ignore label;
- List.fold_left instructions ~init:t ~f:(fun t instruction -> instruction t)
-
- let assign :
- S.pos ->
- (S.pos, Expression.t') S.variable ->
- T.assignation_operator ->
- Expression.t' ->
- t =
- fun _ _ _ _ -> Fun.id
end
module Location = struct
diff --git a/lib/checks/nested_strings.ml b/lib/checks/nested_strings.ml
index e4ffb68..51c5258 100644
--- a/lib/checks/nested_strings.ml
+++ b/lib/checks/nested_strings.ml
@@ -13,16 +13,14 @@ type context = unit
let initialize = Fun.id
let finalize () = []
-module TypeBuilder = Compose.Expression (Get_type)
-
-module Expression = TypeBuilder.Make (struct
+module Expression = Compose.TypeBuilder.Make (struct
type t = Report.t list
type t' = Report.t list
let v : Get_type.t Lazy.t * t -> t' = snd
(** Identify the expressions reprented as string. That’s here that the report
- are added.
+ are added.
All the rest of the module only push thoses warning to the top level. *)
let literal :
diff --git a/lib/checks/type_of.ml b/lib/checks/type_of.ml
index 70ae324..42f9a2d 100644
--- a/lib/checks/type_of.ml
+++ b/lib/checks/type_of.ml
@@ -20,8 +20,8 @@ module Helper = struct
type nonrec t = Get_type.t -> Get_type.t
(** Dynamic type is a type unknown during the code.
- For example, the equality operator accept either Integer or String, but
- we expect that both sides of the equality uses the same type.*)
+ For example, the equality operator accept either Integer or String, but
+ we expect that both sides of the equality uses the same type.*)
(** Build a new dynamic type *)
let t : unit -> t =
@@ -35,11 +35,11 @@ module Helper = struct
| Some t -> t
end
- (** Declare an argument for a function.
+ (** Declare an argument for a function.
- - Either we already know the type and we just have to compare.
- - Either the type shall constrained by another one
- - Or we have a variable number of arguments. *)
+ - Either we already know the type and we just have to compare.
+ - Either the type shall constrained by another one
+ - Or we have a variable number of arguments. *)
type argument =
| Fixed of Get_type.type_of
| Dynamic of DynType.t
@@ -143,8 +143,6 @@ module Helper = struct
msg :: report
end
-module TypeBuilder = Compose.Expression (Get_type)
-
type t' = { result : Get_type.t Lazy.t; pos : S.pos }
let arg_of_repr : Get_type.t Lazy.t -> S.pos -> Helper.argument_repr =
@@ -360,7 +358,7 @@ module TypedExpression = struct
({ pos }, report)
end
-module Expression = TypeBuilder.Make (TypedExpression)
+module Expression = Compose.TypeBuilder.Make (TypedExpression)
module Instruction = struct
type t = Report.t list
diff --git a/lib/checks/write_only.ml b/lib/checks/write_only.ml
index 8363703..e2c3d7e 100644
--- a/lib/checks/write_only.ml
+++ b/lib/checks/write_only.ml
@@ -16,16 +16,8 @@ let active = ref false
let is_global = true
-module Key = struct
- type t = string
-
- let equal = String.equal
- let hash = Hashtbl.hash
- let compare = String.compare
-end
-
-module StringMap = Hashtbl.Make (Key)
-module Set = Set.Make (Key)
+module StringMap = Hashtbl.Make (String)
+module Set = Set.Make (String)
type data = { write : bool; read : bool; position : S.pos list }
type context = (string * data) StringMap.t
diff --git a/lib/qparser/analyzer.ml b/lib/qparser/analyzer.ml
index ca2b54f..b4eeba0 100644
--- a/lib/qparser/analyzer.ml
+++ b/lib/qparser/analyzer.ml
@@ -1,15 +1,23 @@
type 'a result = { content : 'a; report : Qsp_syntax.Report.t list }
+type lexer = Location | Dynamic
-(**
- Run the QSP parser and apply the analyzer over it.
+let get_lexer :
+ Lexbuf.t ->
+ lexer ->
+ unit ->
+ Tokens.token * Lexing.position * Lexing.position =
+ fun l -> function
+ | Location -> Lexbuf.tokenize Lexer.main l
+ | Dynamic -> Lexbuf.tokenize Lexer.dynamics l
+
+(** Run the QSP parser and apply the analyzer over it.
- See [syntax/S]
- *)
-let rec parse :
- type a context.
+ See [syntax/S] *)
+let rec parse : type a context.
(module Qsp_syntax.S.Analyzer
with type Location.t = a
and type context = context) ->
+ lexer ->
Lexbuf.t ->
context ->
(a result, Qsp_syntax.Report.t) Result.t =
@@ -19,10 +27,18 @@ let rec parse :
let module Parser = Parser.Make (S) in
let module IncrementalParser =
Interpreter.Interpreter (Parser.MenhirInterpreter) in
- fun l context ->
- let lexer = Lexbuf.tokenize Lexer.main l in
+ fun lexer_type l context ->
+ let get_parser :
+ lexer ->
+ Lexing.position ->
+ (context -> a) Parser.MenhirInterpreter.checkpoint = function
+ | Location -> Parser.Incremental.main
+ | Dynamic -> Parser.Incremental.dynamics
+ in
+
+ let lexer = get_lexer l lexer_type in
- let init = Parser.Incremental.main (fst (Lexbuf.positions l)) in
+ let init = (get_parser lexer_type) (fst (Lexbuf.positions l)) in
(* Firslty, check if we are able to read the whole syntax from the source *)
let evaluation =
@@ -59,7 +75,7 @@ let rec parse :
application attempt to start from a clean state in the next
location, but may fail to detect the correct position. If so, we
just start again until we hook the next location *)
- parse (module S) l context
+ parse (module S) lexer_type l context
| Error e, _ ->
let message =
match e.IncrementalParser.code with
diff --git a/lib/qparser/analyzer.mli b/lib/qparser/analyzer.mli
index 949db16..817be6c 100644
--- a/lib/qparser/analyzer.mli
+++ b/lib/qparser/analyzer.mli
@@ -1,13 +1,15 @@
type 'a result = { content : 'a; report : Qsp_syntax.Report.t list }
+type lexer = Location | Dynamic
val parse :
(module Qsp_syntax.S.Analyzer
with type Location.t = 'a
and type context = 'context) ->
+ lexer ->
Lexbuf.t ->
'context ->
('a result, Qsp_syntax.Report.t) Result.t
-(** Read the source and build a analyzis over it.
+(** Read the source and build a analyzis over it.
-This method make the link between the source file and how to read it
-(encoding…) and the AST we want to build. *)
+ This method make the link between the source file and how to read it
+ (encoding…) and the AST we want to build. *)
diff --git a/lib/qparser/lexbuf.ml b/lib/qparser/lexbuf.ml
index afc3bac..dbed622 100644
--- a/lib/qparser/lexbuf.ml
+++ b/lib/qparser/lexbuf.ml
@@ -62,8 +62,10 @@ let positions : t -> Lexing.position * Lexing.position =
let content : t -> string = fun t -> Sedlexing.Utf8.lexeme t.buffer
-let from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t =
- fun ?(reset_line = true) t ->
+let from_lexbuf :
+ ?position:Lexing.position -> ?reset_line:bool -> Sedlexing.lexbuf -> t =
+ fun ?position ?(reset_line = true) t ->
+ Option.iter (Sedlexing.set_position t) position;
{
buffer = t;
start_p = None;
diff --git a/lib/qparser/lexbuf.mli b/lib/qparser/lexbuf.mli
index 4283db1..d656642 100644
--- a/lib/qparser/lexbuf.mli
+++ b/lib/qparser/lexbuf.mli
@@ -3,8 +3,11 @@
type t
(** The state of the buffer *)
-val from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t
-(** Create a new buffer *)
+val from_lexbuf :
+ ?position:Lexing.position -> ?reset_line:bool -> Sedlexing.lexbuf -> t
+(** Create a new buffer.
+
+ If a position is given, start from this position in the file. *)
val start : t -> unit
(** Intialize a new run. *)
@@ -13,11 +16,10 @@ val buffer : t -> Sedlexing.lexbuf
(** Extract the sedlex buffer. Required in each rule. *)
val positions : t -> Lexing.position * Lexing.position
-(** Extract the starting and ending position for the matched token.
+(** Extract the starting and ending position for the matched token.
- This function is used outside of the parser, in order to get the position
- of the latest token in the case of an error.
- *)
+ This function is used outside of the parser, in order to get the position of
+ the latest token in the case of an error. *)
val content : t -> string
(** Extract the token matched by the rule *)
@@ -33,15 +35,14 @@ val tokenize : (t -> 'a) -> t -> unit -> 'a * Lexing.position * Lexing.position
val rollback : t -> unit
(** Rollback the latest token matched *)
-(** {1 State in expressions}
+(** {1 State in expressions}
- The comment system is terrible. The same symbol can be used for :
- - starting a comment
- - inequality operation
+ The comment system is terrible. The same symbol can be used for :
+ - starting a comment
+ - inequality operation
- In order to manage this, I try to identify the context in a very basic way,
- using a stack for determining the token to send.
-*)
+ In order to manage this, I try to identify the context in a very basic way,
+ using a stack for determining the token to send. *)
type lexer = t -> Tokens.token
and buffer_builder = ?nested:bool -> Buffer.t -> t -> Tokens.token
@@ -64,14 +65,14 @@ type state =
| String of stringWraper (** String enclosed by [''] *)
| MString of int (** String enclosed by [{}]*)
| EndString of stringWraper
- (** State raised just before closing the string.
- The buffer is rollbacked and the position is the closing symbol. *)
+ (** State raised just before closing the string. The buffer is rollbacked
+ and the position is the closing symbol. *)
| Expression (** Expression where [!] is an operator *)
val pp_state : Format.formatter -> state -> unit
val state : t -> state option
-(** Get the current state for the lexer.
+(** Get the current state for the lexer.
@return [None] when in the default state *)
@@ -84,8 +85,8 @@ val leave_state : t -> unit
val overlay : t -> lexer -> lexer
val start_recovery : t -> unit
-(** Set the lexer in recovery mode, the lexer raise this mode after an error,
- in order to ignore the further errors until a new location *)
+(** Set the lexer in recovery mode, the lexer raise this mode after an error, in
+ order to ignore the further errors until a new location *)
val is_recovery : t -> bool
(** Check if the lexer is in recovery mode *)
diff --git a/lib/qparser/lexer.ml b/lib/qparser/lexer.ml
index 814c97f..470cdc7 100644
--- a/lib/qparser/lexer.ml
+++ b/lib/qparser/lexer.ml
@@ -1,6 +1,4 @@
-(**
- Lexer using sedlex
- *)
+(** Lexer using sedlex *)
open Tokens
open StdLabels
@@ -12,7 +10,8 @@ exception EOF
(* Extract the location name from the pattern *)
let location_name = Str.regexp {|# *\(.*\)|}
-(** Remove all the expression state when we are leaving the expression itself. *)
+(** Remove all the expression state when we are leaving the expression itself.
+*)
let rec leave_expression buffer =
match Lexbuf.state buffer with
| Some Lexbuf.Expression ->
@@ -21,7 +20,7 @@ let rec leave_expression buffer =
| _ -> ()
(** Try to read the identifier and check if this is a function, a keyword, or
- just a variable.
+ just a variable.
See the tests [Syntax.Operator2] and [Syntax.Call Nl] for two cases. *)
let build_ident buffer =
@@ -124,8 +123,7 @@ let rec read_long_string : ?nested:bool -> int -> Buffer.t -> Lexbuf.t -> token
rollbacked, leaving the state in [Lexbuf.EndString _].
The next call to [main] will call the associated function, effectively
- leaving the string mode in the parser.
- *)
+ leaving the string mode in the parser. *)
let rec read_quoted_string : Lexbuf.stringWraper -> Lexbuf.buffer_builder =
fun f ?(nested = false) buf buffer ->
let lexbuf = Lexbuf.buffer buffer in
@@ -153,11 +151,9 @@ let rec read_quoted_string : Lexbuf.stringWraper -> Lexbuf.buffer_builder =
(f.wrap ~nested (read_quoted_string f)) buf buffer
| _ -> raise Not_found
-(** Track the kind of nested string inside a multiline string inside a
- comment.
+(** Track the kind of nested string inside a multiline string inside a comment.
- Some constructions are not allowed in this specific case (see later)
-*)
+ Some constructions are not allowed in this specific case (see later) *)
type commentedString = None | Quote | DQuote
let rec skip_comment buffer =
@@ -333,6 +329,10 @@ let main buffer =
in
parser buffer
+(** Function used inside the dynamics expressions. Here, we give the EOF token
+ to the parser. *)
+let dynamics buffer = try main buffer with EOF -> Tokens.EOF
+
let rec discard buffer =
let () = Lexbuf.start_recovery buffer in
let lexbuf = Lexbuf.buffer buffer in
diff --git a/lib/qparser/lexer.mli b/lib/qparser/lexer.mli
index 854bb1e..70902e6 100644
--- a/lib/qparser/lexer.mli
+++ b/lib/qparser/lexer.mli
@@ -18,3 +18,5 @@ val discard : Lexbuf.t -> unit
val main : Lexbuf.t -> Tokens.token
(** Main entry point. This function is called after each token returned *)
+
+val dynamics : Lexbuf.t -> Tokens.token
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index d075e3e..469cf79 100644
--- a/lib/qparser/parser.mly
+++ b/lib/qparser/parser.mly
@@ -19,11 +19,13 @@
%parameter<Analyzer: Qsp_syntax.S.Analyzer>
%start <(Analyzer.context -> Analyzer.Location.t)>main
+%start<(Analyzer.context -> Analyzer.Location.t)>dynamics
+
%on_error_reduce expression instruction unary_operator assignation_operator
%%
-main:
+main:
| before_location*
start_location
EOL+
@@ -34,6 +36,21 @@ main:
fun context -> Analyzer.Location.location context $loc instructions
}
+dynamics:
+ | EOL*
+ instructions = line_statement+
+ EOF
+ {
+ let instructions = List.map instructions ~f:(Analyzer.Instruction.v) in
+ fun context -> Analyzer.Location.location context $loc instructions
+ }
+ | EOL*
+ b = inlined_block(EOF)
+ {
+ let instruction = (Analyzer.Instruction.v b) in
+ fun context -> Analyzer.Location.location context $loc [instruction]
+ }
+
before_location:
| EOL {}
| COMMENT EOL { }
diff --git a/lib/qparser/tokens.mly b/lib/qparser/tokens.mly
index 0ba5486..42856ef 100644
--- a/lib/qparser/tokens.mly
+++ b/lib/qparser/tokens.mly
@@ -20,6 +20,7 @@
%token AND OR
%token EOL
+%token EOF
%token <string>IDENT
%token <string>LITERAL
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index 918d8e6..a3c74ca 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -8,11 +8,20 @@
(** {1 Generic types used in the module} *)
-type pos = Lexing.position * Lexing.position
+type position = Lexing.position = {
+ pos_fname : string;
+ pos_lnum : int;
+ pos_bol : int;
+ pos_cnum : int;
+}
+[@@deriving eq, ord]
+
+type pos = position * position [@@deriving eq, ord]
(** The type pos is used to track the starting and ending position for the given
location. *)
type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }
+[@@deriving eq, ord]
(** Describe a variable, using the name in capitalized text, and an optionnal
index.
diff --git a/lib/syntax/catalog.ml b/lib/syntax/catalog.ml
index b516976..5ad0bbd 100644
--- a/lib/syntax/catalog.ml
+++ b/lib/syntax/catalog.ml
@@ -18,31 +18,31 @@ type ex =
-> ex (** Type of check to apply *)
let build :
+ ?location_id:'a Type.Id.t ->
+ ?context_id:'b Type.Id.t ->
(module S.Analyzer
with type Expression.t = _
and type Expression.t' = _
and type Instruction.t = _
and type Instruction.t' = _
and type Location.t = 'a
- and type context = _) ->
- 'a Type.Id.t * ex =
- fun module_ ->
+ and type context = 'b) ->
+ ex =
+ fun ?location_id ?context_id module_ ->
let expr_witness = Type.Id.make ()
and expr' = Type.Id.make ()
and instr_witness = Type.Id.make ()
and instr' = Type.Id.make ()
- and location_witness = Type.Id.make ()
- and context = Type.Id.make () in
- let t =
- E
- {
- module_;
- expr_witness;
- expr';
- instr_witness;
- instr';
- location_witness;
- context;
- }
- in
- (location_witness, t)
+ and location_witness =
+ match location_id with Some v -> v | None -> Type.Id.make ()
+ and context = match context_id with Some v -> v | None -> Type.Id.make () in
+ E
+ {
+ module_;
+ expr_witness;
+ expr';
+ instr_witness;
+ instr';
+ location_witness;
+ context;
+ }
diff --git a/lib/syntax/catalog.mli b/lib/syntax/catalog.mli
index a256c17..a386d4a 100644
--- a/lib/syntax/catalog.mli
+++ b/lib/syntax/catalog.mli
@@ -18,13 +18,15 @@ type ex =
-> ex (** Type of check to apply *)
val build :
+ ?location_id:'a Type.Id.t ->
+ ?context_id:'b Type.Id.t ->
(module S.Analyzer
with type Expression.t = _
and type Expression.t' = _
and type Instruction.t = _
and type Instruction.t' = _
and type Location.t = 'a
- and type context = _) ->
- 'a Type.Id.t * ex
+ and type context = 'b) ->
+ ex
(** Build a new check from a module following S.Analyzer signature. ypeid Return
the result type which hold the final result value, and checker itself. *)
diff --git a/lib/syntax/dune b/lib/syntax/dune
index 666273f..9832809 100644
--- a/lib/syntax/dune
+++ b/lib/syntax/dune
@@ -2,5 +2,7 @@
(name qsp_syntax)
(preprocess (pps
- ppx_deriving.show ppx_deriving.enum
+ ppx_deriving.show
+ ppx_deriving.enum
+ ppx_deriving.ord
ppx_deriving.eq )))
diff --git a/readme.md b/readme.md
index 6b6c535..a4f239e 100644
--- a/readme.md
+++ b/readme.md
@@ -89,7 +89,7 @@ will not report this usage when an integer converted into a string this way.
In a single if branch, check if the same is repeated more than one once. In
this case, only the first case is executed and the other test is ignored.
-A warining will be raised here:
+A warning will be raised here:
if $value = '1':
! Do something
diff --git a/test/dup_cases.ml b/test/dup_cases.ml
index 8b9f846..76a1157 100644
--- a/test/dup_cases.ml
+++ b/test/dup_cases.ml
@@ -28,8 +28,7 @@ elseif rnd:
end
|} []
-(** The same test in two differents block shall be considered as a duplicate.
- *)
+(** The same test in two differents block shall be considered as a duplicate. *)
let ok_act () =
_test_instruction
{|
@@ -61,14 +60,13 @@ end
{
level = Warn;
loc = _position;
- message = "This case is duplicated line(s) 5";
+ message = "This case is duplicated line(s) 4";
};
]
let duplicate_root_test () =
_test_instruction
- {|
-if args[0] = 1:
+ {|if args[0] = 1:
0
end
if args[0] = 1:
@@ -81,7 +79,7 @@ end
{
level = Warn;
loc = _position;
- message = "This case is duplicated line(s) 6";
+ message = "This case is duplicated line(s) 4";
};
]
diff --git a/test/dynamics.ml b/test/dynamics.ml
new file mode 100644
index 0000000..ad980f4
--- /dev/null
+++ b/test/dynamics.ml
@@ -0,0 +1,93 @@
+module Check = Make_checkTest.M (Qsp_checks.Dynamics)
+module S = Qsp_syntax.S
+
+let position = (Lexing.dummy_pos, Lexing.dummy_pos)
+
+module Testable = struct
+ type pos = S.pos
+
+ let pp_pos = Qsp_syntax.Report.pp_pos
+ let equal_pos : pos -> pos -> bool = fun _ _ -> true
+
+ type t = Qsp_checks.Dynamics.text = { content : string; position : pos }
+ [@@deriving show, eq]
+
+ let v = Alcotest.list (Alcotest.testable pp equal)
+end
+
+let _parse : string -> Testable.t list -> unit =
+ fun literal expected ->
+ let context = Qsp_checks.Dynamics.initialize () in
+ (* The result of the parsing can be discarded, the usefull information is in
+ the context *)
+ let result =
+ Check._parse ~context Qparser.Analyzer.Dynamic (literal ^ "\n")
+ in
+ match result with
+ | Ok _ ->
+ let actual : Qsp_checks.Dynamics.text List.t =
+ Qsp_checks.Dynamics.dynamics_string context |> List.of_seq
+ in
+ let msg = literal in
+ Alcotest.(check' Testable.v ~msg ~expected ~actual)
+ | Error _ -> raise (Failure "Syntax error")
+
+let test_direct () =
+ _parse "dynamic '$a = 1'"
+ [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ]
+
+let test_indirect () =
+ _parse "$test = '$a = 1' & dynamic $test"
+ [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ]
+
+let test_indirect_array () =
+ _parse "$test[0] = '$a = 1' & dynamic $test[0]"
+ [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ];
+
+ _parse "$test['a'] = '$a = 1' & dynamic $test['a']"
+ [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ];
+
+ _parse "$test[0] = '$a = 1' & dynamic $test[1]" []
+
+(** If a variable is identified as dynamic, check all the differents values this
+ variable can have *)
+let test_reassignation () =
+ _parse
+ {|$test = '$a = 1'
+ $test = '$a = 2'
+ dynamic $test|}
+ [
+ { Qsp_checks.Dynamics.content = "$a = 1"; position };
+ { Qsp_checks.Dynamics.content = "$a = 2"; position };
+ ]
+
+(** If the variable contains a dynamic assignation, blacklist it from being
+ checkable*)
+let test_blacklist () =
+ _parse {|$test = '$a = 1'
+ $test = $b + ''
+ dynamic $test|} []
+
+(** Ignore string template because this can be anything *)
+let test_template_str () = _parse "dynamic '$a = <<$other>>'" []
+
+let test_template_str2 () =
+ _parse {|dynamic '$a = <<"other">>'|}
+ [ { Qsp_checks.Dynamics.content = "$a = other"; position } ]
+
+let test_template_int () =
+ _parse "dynamic '$a = <<other>>'"
+ [ { Qsp_checks.Dynamics.content = "$a = 0"; position } ]
+
+let test =
+ ( "Dynamic evaluation checker",
+ [
+ Alcotest.test_case "direct" `Quick test_direct;
+ Alcotest.test_case "indirect" `Quick test_indirect;
+ Alcotest.test_case "indirect array" `Quick test_indirect_array;
+ Alcotest.test_case "template" `Quick test_template_str;
+ Alcotest.test_case "template" `Quick test_template_str2;
+ Alcotest.test_case "template int" `Quick test_template_int;
+ Alcotest.test_case "reassignation" `Quick test_reassignation;
+ Alcotest.test_case "blacklist" `Quick test_blacklist;
+ ] )
diff --git a/test/literals.ml b/test/literals.ml
index f98fa8f..2685538 100644
--- a/test/literals.ml
+++ b/test/literals.ml
@@ -107,6 +107,20 @@ let multiple_expression () =
] ));
]
+let int_expression () =
+ _test_instruction {|"<<expr2>>"|}
+ [
+ Tree.Ast.Expression
+ (Tree.Ast.Literal
+ ( _position,
+ [
+ T.Expression
+ (Tree.Ast.Ident
+ { Tree.Ast.pos = _position; name = "EXPR2"; index = None });
+ T.Text "";
+ ] ));
+ ]
+
let test =
( "Literals",
[
@@ -127,4 +141,5 @@ let test =
Alcotest.test_case "elements_sequence" `Quick elements_sequence;
Alcotest.test_case "expression" `Quick expression;
Alcotest.test_case "multiple_expression" `Quick multiple_expression;
+ Alcotest.test_case "multiple_expression" `Quick int_expression;
] )
diff --git a/test/location.ml b/test/location.ml
index a1939f4..cf2008f 100644
--- a/test/location.ml
+++ b/test/location.ml
@@ -18,6 +18,14 @@ let ok_upper () = Check.global_check "gt 'LOCATION'" []
let missing_gt () = Check.global_check "gt 'unknown_place'" error_message
let missing_gs () = Check.global_check "gs 'unknown_place'" error_message
+let act_missing_gs () =
+ Check.global_check {|
+act "test": gs 'unknown_place'|} error_message
+
+let if_missing_gs () =
+ Check.global_check {|
+ if 0: gs 'unknown_place'|} error_message
+
let test =
( "Locations",
[
@@ -25,4 +33,6 @@ let test =
Alcotest.test_case "Ok upper" `Quick ok_upper;
Alcotest.test_case "Missing GT" `Quick missing_gt;
Alcotest.test_case "Missing GS" `Quick missing_gs;
+ Alcotest.test_case "Missing GS in block" `Quick act_missing_gs;
+ Alcotest.test_case "Missing GS in block'" `Quick if_missing_gs;
] )
diff --git a/test/make_checkTest.ml b/test/make_checkTest.ml
index d3ad358..a863214 100644
--- a/test/make_checkTest.ml
+++ b/test/make_checkTest.ml
@@ -23,42 +23,42 @@ module M (Check : Qsp_syntax.S.Analyzer) = struct
@@ Alcotest.pair Alcotest.string
(Alcotest.testable Qsp_syntax.Report.pp equal)
- let parse :
+ let _parse :
?context:Check.context ->
+ Qparser.Analyzer.lexer ->
string ->
(Check.Location.t Qparser.Analyzer.result, t) result =
- fun ?context content ->
+ fun ?context lexer content ->
let lexing =
Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
in
let context = Option.value context ~default:(Check.initialize ()) in
- Qparser.Analyzer.parse (module Check) lexing context
+ Qparser.Analyzer.parse (module Check) lexer lexing context
let get_report :
(Check.Location.t Qparser.Analyzer.result, Qsp_syntax.Report.t) result ->
Qsp_syntax.Report.t list = function
| Ok v -> v.report
- | Error _ -> failwith "Error"
+ | Error msg -> failwith msg.message
let _test_instruction : string -> t list -> unit =
fun literal expected ->
- let _location = Printf.sprintf {|# Location
-%s
-------- |} literal in
- let actual = get_report @@ parse _location and msg = literal in
+ let actual = get_report @@ _parse Qparser.Analyzer.Dynamic literal
+ and msg = literal in
Alcotest.(check' report ~msg ~expected ~actual)
- (** Run a test over the whole file.
- The parsing of the content shall not report any error.
- *)
+ (** Run a test over the whole file. The parsing of the content shall not
+ report any error. *)
let global_check : string -> (string * t) list -> unit =
fun literal expected ->
let _location = Printf.sprintf {|# Location
%s
------- |} literal in
let context = Check.initialize () in
- let actual = get_report @@ parse ~context _location in
+ let actual =
+ get_report @@ _parse ~context Qparser.Analyzer.Location _location
+ in
let () =
Alcotest.(
check' report ~msg:"Error reported during parsing" ~expected:[] ~actual)
diff --git a/test/qsp_parser_test.ml b/test/qsp_parser_test.ml
index 43f9cb3..4ae5a4c 100644
--- a/test/qsp_parser_test.ml
+++ b/test/qsp_parser_test.ml
@@ -11,4 +11,5 @@ let () =
Nested_string.test;
Location.test;
Dup_cases.test;
+ Dynamics.test;
]
diff --git a/test/syntax.ml b/test/syntax.ml
index db449b1..ff5a3ca 100644
--- a/test/syntax.ml
+++ b/test/syntax.ml
@@ -4,7 +4,8 @@ module Check = Qsp_checks.Check
module S = Qsp_syntax.S
module T = Qsp_syntax.T
-let location_id, e1 = Qsp_syntax.Catalog.build (module Tree)
+let location_id = Type.Id.make ()
+let e1 = Qsp_syntax.Catalog.build ~location_id (module Tree)
module Parser = Check.Make (struct
let t = [| e1 |]
@@ -28,7 +29,9 @@ let parse : string -> (S.pos location, Qsp_syntax.Report.t) result =
Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
in
let context = Parser.initialize () in
- Qparser.Analyzer.parse (module Parser) lexing context
+ Qparser.Analyzer.parse
+ (module Parser)
+ Qparser.Analyzer.Location lexing context
|> Result.map (fun v ->
(* Uncatched excteptions here, but we are in the tests…
If it’s fail here I have an error in the code. *)
--
cgit v1.2.3