Added dynamic check mecanismHEADmaster

11 files changed, 402 insertions, 116 deletions

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