|
@@ -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
|