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
---
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 +-
11 files changed, 402 insertions(+), 116 deletions(-)
create mode 100644 lib/checks/dynamics.ml
create mode 100644 lib/checks/dynamics.mli
(limited to 'lib/checks')
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
--
cgit v1.2.3