Added dynamic check mecanismHEADmaster

1 files changed, 262 insertions, 0 deletions

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