qsp_parser/lib/syntax/dup_test.ml

(** 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.
 *)

open StdLabels

let identifier = "duplicate_test"
let description = "Check for duplicate tests"
let is_global = false
let active = ref true

type context = unit

let initialize = Fun.id
let finalize () = []

module Expression = Tree.Expression

(** Build a Hashtbl over the expression, ignoring the location in the
    expression *)
module Table = Hashtbl.Make (struct
  type t = Expression.t'

  let equal : t -> t -> bool = Tree.Expression.eq (fun _ _ -> true)
  let hash : t -> int = Tree.Expression.hash (fun _ -> 0)
end)

module Instruction = struct
  type state = {
    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. *)

  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

  (** Comment *)
  let comment : S.pos -> t = fun _ -> default

  (** Raw expression *)
  let expression : Expression.t' -> t = fun _ -> default

  let check_duplicates :
      (Expression.t' * S.pos) list -> (Expression.t' * S.pos list) list =
   fun predicates ->
    let table = Table.create 5 in
    let () = List.to_seq predicates |> Table.add_seq table in

    Table.to_seq_keys table
    |> Seq.group (Tree.Expression.eq (fun _ _ -> true))
    |> Seq.filter_map (fun keys ->
           (* Only take the first element for each group, we don’t need to
              repeat the key *)
           match Seq.uncons keys with
           | None -> None
           | Some (hd, _) -> (
               match Table.find_all table hd with
               | [] | _ :: [] -> None
               | 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 *)
  let predicate_of_clause : ?pos:S.pos -> t -> (Expression.t', t) S.clause -> t
      =
   fun ?pos t (pos2, predicate, blocks) ->
    let pos = Option.value ~default:pos2 pos in

    (* Remove the clauses using the function rnd because they repeating the
       same clause can generate a different result *)
    let should_discard =
      Tree.Expression.exists predicate ~f:(function
        | Tree.Ast.Function (_, T.Rand, _) | Tree.Ast.Function (_, T.Rnd, _) ->
            true
        | _ -> false)
    in

    {
      predicates =
        (match should_discard with
        | false -> (predicate, pos) :: t.predicates
        | true -> t.predicates);
      duplicates =
        List.fold_left blocks ~init:t.duplicates ~f:(fun acc t ->
            List.rev_append t.duplicates acc);
    }

  let if_ :
      S.pos ->
      (Expression.t', t) S.clause ->
      elifs:(Expression.t', t) S.clause list ->
      else_:(S.pos * t list) option ->
      t =
   fun pos clause ~elifs ~else_ ->
    ignore else_;
    (* Collect all the if clauses from this block, wait for the parent block to
       check each case for duplicates. *)
    let init = predicate_of_clause ~pos default clause in
    let state = List.fold_left elifs ~init ~f:predicate_of_clause in
    {
      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

  let for_ :
      S.pos ->
      (S.pos, Expression.t') S.variable ->
      start:Expression.t' ->
      to_:Expression.t' ->
      step:Expression.t' option ->
      t list ->
      t =
   fun _loc variable ~start ~to_ ~step statements ->
    ignore variable;
    ignore start;
    ignore to_;
    ignore step;
    List.fold_left ~init:default statements ~f:(fun state ex ->
        {
          predicates = [];
          duplicates = List.rev_append ex.duplicates state.duplicates;
        })
end

module Location = struct
  type t = (Expression.t' * S.pos list) list

  type context = unit
  (** No context *)

  (** Check if the given expression is involving the variable ARGS or $ARGS *)
  let is_args : Expression.t' -> bool = function
    | Tree.Ast.Ident { name; _ } ->
        String.equal name "ARGS" || String.equal name "$ARGS"
    | _ -> false

  let location : context -> S.pos -> Instruction.t' list -> t =
   fun () _ block ->
    (* Filter the tests from the top level and only keep them testing ARGS *)
    let duplicates =
      List.map block ~f:(fun t ->
          List.filter_map t.Instruction.predicates ~f:(fun v ->
              match (Tree.Expression.exists ~f:is_args) (fst v) with
              | true -> Some v
              | false -> None))
      |> List.concat |> Instruction.check_duplicates
    in
    List.fold_left ~init:duplicates block ~f:(fun state ex ->
        List.rev_append ex.Instruction.duplicates state)

  (** Create the report message *)
  let v' : Expression.t' * S.pos list -> Report.t option =
   fun (expr, pos) ->
    ignore expr;
    match (List.sort ~cmp:Report.compare_pos) pos with
    | [] -> None
    | _ :: [] -> None
    | hd :: tl ->
        let message =
          Format.asprintf "This case is duplicated line(s) %a"
            (Format.pp_print_list
               ~pp_sep:(fun f () -> Format.pp_print_char f ',')
               Report.pp_line)
            tl
        in

        (* Report all the messages as error. They do not break the game, but
           there is no question if it should *)
        Some (Report.error hd message)

  let v : t -> Report.t list =
   fun t -> List.filter_map t ~f:v' |> List.sort_uniq ~cmp:Report.compare
end