New test for duplicates evalutations in the code

bin/qsp_parser.ml

@@ -23,6 +23,7 @@ let available_checks =
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Dead_end);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Nested_strings);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Locations);
+    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Dup_test);
   ]
 
 let pp_module formatter (module A : Qsp_syntax.S.Analyzer) =

lib/syntax/dup_test.ml

@@ -0,0 +1,187 @@
+(** 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
+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
+
+        (* Ignore the first case, and report all the following ones *)
+        Some (Report.warn hd message)
+
+  let v : t -> Report.t list =
+   fun t -> List.filter_map t ~f:v' |> List.sort_uniq ~cmp:Report.compare
+end

lib/syntax/dup_test.mli

@@ -0,0 +1 @@
+include S.Analyzer

lib/syntax/report.ml

@@ -28,22 +28,34 @@ let pp_pos : Format.formatter -> pos -> unit =
     Format.fprintf f "Lines %d-%d" start_line end_line
   else Format.fprintf f "Line %d %d:%d" start_line start_c end_c
 
+let pp_line : Format.formatter -> pos -> unit =
+ fun f (start_pos, end_pos) ->
+  (* Only care about the first line *)
+  ignore end_pos;
+  let start_line = start_pos.Lexing.pos_lnum in
+  Format.fprintf f "%d" start_line
+
 type t = { level : level; loc : pos; message : string }
 [@@deriving show { with_path = false }]
 
+(** Compare two positions *)
+let compare_pos : pos -> pos -> int =
+ fun (pos1_start, pos1_end) (pos2_start, pos2_end) ->
+  (* first compare the position *)
+  match compare pos1_start.pos_cnum pos2_start.pos_cnum with
+  | 0 ->
+      (* Then the ending position *)
+      compare pos1_end.pos_cnum pos2_end.pos_cnum
+  | other -> other
+
 let compare : t -> t -> int =
  fun t1 t2 ->
   (* first compare the position *)
-  let pos1_start, pos1_end = t1.loc and pos2_start, pos2_end = t2.loc in
-  match compare pos1_start.pos_cnum pos2_start.pos_cnum with
+  match compare_pos t1.loc t2.loc with
   | 0 -> (
-      (* Then the ending position *)
-      match compare pos1_end.pos_cnum pos2_end.pos_cnum with
-      | 0 -> (
-          (* And the level *)
-          match compare (level_to_enum t1.level) (level_to_enum t2.level) with
-          | 0 -> String.compare t1.message t2.message
-          | other -> other)
+      (* And the level *)
+      match compare (level_to_enum t1.level) (level_to_enum t2.level) with
+      | 0 -> String.compare t1.message t2.message
       | other -> other)
   | other -> other
 

lib/syntax/tree.ml

@@ -48,14 +48,31 @@ end
 module Expression : sig
   include S.Expression with type t' = S.pos Ast.expression
 
-  val eq : (S.pos -> S.pos -> bool) -> t -> t -> bool
-  val hash : (S.pos -> int) -> t -> int
+  val eq : (S.pos -> S.pos -> bool) -> t' -> t' -> bool
+  val hash : (S.pos -> int) -> t' -> int
+  val exists : f:(t' -> bool) -> t' -> bool
 end = struct
   type t = S.pos Ast.expression
   type t' = t
 
   let eq : (S.pos -> S.pos -> bool) -> t -> t -> bool = Ast.equal_expression
 
+  (* Add a way to filter an expression *)
+  let rec exists : f:(t -> bool) -> t -> bool =
+   fun ~f -> function
+    | BinaryOp (_, _, o1, o2) as op -> f op || exists ~f o1 || exists ~f o2
+    | Op (_, _, expr) as op -> f op || exists ~f expr
+    | Function (_, _, exprs) as fn -> f fn || List.exists exprs ~f:(exists ~f)
+    | Literal (_, litts) as litt ->
+        f litt
+        || List.exists litts ~f:(function
+             | T.Text _ -> false
+             | T.Expression ex -> exists ~f ex)
+    | Ident { index; _ } as ident -> (
+        f ident
+        || match index with None -> false | Some expr -> exists ~f expr)
+    | Integer _ as int -> f int
+
   let rec hash : (S.pos -> int) -> t -> int =
    fun f -> function
     | Integer (pos, v) -> Hashtbl.hash (f pos, v)

lib/syntax/tree.mli

@@ -47,8 +47,9 @@ end
 module Expression : sig
   include S.Expression with type t' = S.pos Ast.expression
 
-  val eq : (S.pos -> S.pos -> bool) -> t -> t -> bool
-  val hash : (S.pos -> int) -> t -> int
+  val eq : (S.pos -> S.pos -> bool) -> t' -> t' -> bool
+  val hash : (S.pos -> int) -> t' -> int
+  val exists : f:(t' -> bool) -> t' -> bool
 end
 
 include

test/dup_cases.ml

@@ -0,0 +1,128 @@
+module Check = Make_checkTest.M (Qsp_syntax.Dup_test)
+
+let _position = (Lexing.dummy_pos, Lexing.dummy_pos)
+
+let _test_instruction : string -> Qsp_syntax.Report.t list -> unit =
+  Check._test_instruction
+
+(** Two differents test shall not report error *)
+let ok () =
+  _test_instruction {|
+if 1: 
+    0
+elseif 2:
+    0
+end
+
+if 3: 
+    0
+end
+|} []
+
+(** The rnd function can generate different result, this is not a warning *)
+let ok_rnd () =
+  _test_instruction {|
+if rnd(): 
+    0
+elseif rnd():
+    0
+end
+|} []
+
+(** The same test in two differents block shall be considered as a duplicate.
+ *)
+let ok_act () =
+  _test_instruction
+    {|
+
+act "action":
+    if 1: 
+        0
+    end
+end
+
+act "action":
+    if 1: 
+        0
+    end
+end
+|}
+    []
+
+let duplicate_case () =
+  _test_instruction
+    {|
+if 0 = '1': 
+    0
+elseif 0 = '1':
+    0
+end
+|}
+    [
+      {
+        level = Warn;
+        loc = _position;
+        message = "This case is duplicated line(s) 5";
+      };
+    ]
+
+let duplicate_root_test () =
+  _test_instruction
+    {|
+if args[0] = 1: 
+    0
+end
+if args[0] = 1: 
+    0
+elseif 1:
+    0
+end
+|}
+    [
+      {
+        level = Warn;
+        loc = _position;
+        message = "This case is duplicated line(s) 6";
+      };
+    ]
+
+let duplicate_nonroot_test () =
+  _test_instruction
+    {|
+act 0:
+    if 1: 
+        0
+    end
+    if 1:
+        0
+    end
+end
+
+if 0:
+    if 1: 
+        0
+    end
+    if 1:
+        0
+    end
+else
+    if 1: 
+        0
+    end
+    if 1:
+        0
+    end
+end
+|}
+    []
+
+let test =
+  ( "Duplicates predicates checker",
+    [
+      Alcotest.test_case "Ok" `Quick ok;
+      Alcotest.test_case "Ok rnd" `Quick ok_rnd;
+      Alcotest.test_case "Ok_act" `Quick ok_act;
+      Alcotest.test_case "duplicate_cases" `Quick duplicate_case;
+      Alcotest.test_case "duplicate_root" `Quick duplicate_root_test;
+      Alcotest.test_case "duplicate_nonroottest" `Quick duplicate_nonroot_test;
+    ] )

test/qsp_parser_test.ml

@@ -8,4 +8,5 @@ let () =
       Dead_end.test;
       Nested_string.test;
       Location.test;
+      Dup_cases.test;
     ]