path: root/lib/checks/dynamics.ml

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