Allow test to be enabled or disabled by command line

9 files changed, 93 insertions, 18 deletions

diff --git a/bin/args.ml b/bin/args.ml
index 0021b34..a98981c 100644
--- a/bin/args.ml
+++ b/bin/args.ml
@@ -1,3 +1,4 @@
+open StdLabels
 module Report = Qsp_syntax.Report
 
 let input_files = ref []
@@ -23,7 +24,25 @@ let level : string -> unit =
       print_endline e;
       exit 1
 
-let speclist printer =
+let disable_module modules identifier =
+  let identifier =
+    String.sub identifier ~pos:1 ~len:(String.length identifier - 1)
+  in
+  List.iter modules ~f:(fun t ->
+      let (module C : Qsp_syntax.S.Analyzer) = Qsp_syntax.Check.get_module t in
+      if String.equal C.identifier identifier then C.active := false)
+
+let enable_module modules identifier =
+  let identifier =
+    String.sub identifier ~pos:1 ~len:(String.length identifier - 1)
+  in
+  List.iter modules ~f:(fun t ->
+      let (module C : Qsp_syntax.S.Analyzer) = Qsp_syntax.Check.get_module t in
+      if String.equal C.identifier identifier then C.active := true)
+
+let speclist modules printer =
+  ignore modules;
+
   let common_arguments =
     [
       ( "--version",
@@ -45,6 +64,8 @@ let speclist printer =
         Arg.Set reset_line,
         "\tEach line is refered from the begining of the file and not the \
          location" );
+      ("-<test>", Arg.String anon_fun, "\tDisable this test");
+      ("+<test>", Arg.Unit (fun () -> ()), "\tEnable this test");
     ]
   and windows_arguments =
     match Sys.os_type with
@@ -54,9 +75,29 @@ let speclist printer =
   in
   common_arguments @ windows_arguments
 
-let parse : list_tests:(Format.formatter -> unit) -> string list * t =
- fun ~list_tests ->
-  let speclist = speclist list_tests in
+let parse :
+    modules:Qsp_syntax.Check.t list ->
+    list_tests:(Format.formatter -> unit) ->
+    string list * t =
+ fun ~modules ~list_tests ->
+  let speclist = speclist modules list_tests in
+  let speclist =
+    let r = ref speclist in
+    for i = 1 to pred (Array.length Sys.argv) do
+      let s = Sys.argv.(i) in
+      if
+        s.[0] = '-'
+        && not (List.exists !r ~f:(fun (s', _, _) -> String.equal s s'))
+      then
+        r :=
+          ( s,
+            Arg.Unit (fun () -> disable_module modules s),
+            "\tDisable this test" )
+          :: !r
+      else if s.[0] = '+' then enable_module modules s
+    done;
+    !r
+  in
   let () = Arg.parse (Arg.align speclist) anon_fun usage in
 
   match !input_files with
diff --git a/bin/args.mli b/bin/args.mli
index cffd0d0..fb15542 100644
--- a/bin/args.mli
+++ b/bin/args.mli
@@ -3,4 +3,7 @@ type filters = { level : Qsp_syntax.Report.level option }
 type t = { reset_line : bool; filters : filters }
 (** All the arguments given from the command line *)
 
-val parse : list_tests:(Format.formatter -> unit) -> string list * t
+val parse :
+  modules:Qsp_syntax.Check.t list ->
+  list_tests:(Format.formatter -> unit) ->
+  string list * t
diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml
index db07c82..1b2b90c 100644
--- a/bin/qsp_parser.ml
+++ b/bin/qsp_parser.ml
@@ -18,32 +18,40 @@ type ctx = { error_nb : int; warn_nb : int; debug_nb : int }
     List all the controls to apply 
  *)
 let available_checks =
-  [|
+  [
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Type_of);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Dead_end);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Nested_strings);
-  |]
+  ]
 
-let pp_print_module formatter (module A : Qsp_syntax.S.Analyzer) =
+let pp_module formatter (module A : Qsp_syntax.S.Analyzer) =
   Format.fprintf formatter "%s" A.identifier;
   Format.pp_print_tab formatter ();
+  (match !A.active with
+  | true -> Format.fprintf formatter "*"
+  | false -> Format.fprintf formatter " ");
+  Format.pp_print_tab formatter ();
   Format.fprintf formatter "%s" A.description;
   ()
 
-let pp_print_modules formatter =
+(** Print all the available modules *)
+let pp_modules formatter =
   let max_length =
-    Array.fold_left available_checks ~init:0 ~f:(fun l v ->
+    List.fold_left available_checks ~init:0 ~f:(fun l v ->
         let (module A : Qsp_syntax.S.Analyzer) =
           Qsp_syntax.Check.get_module v
         in
         max l (String.length A.identifier))
   in
 
-  let ll = Array.to_list available_checks in
   Format.pp_open_tbox formatter ();
 
-  (* Print the name, left justified, with enougth spaces for the identifier *)
+  (* Print the name, left justified, with enought spaces for the all the
+     identifiers *)
   Format.fprintf formatter "%-*s" (max_length + 1) "Name";
+  (* Tab delimiter *)
+  Format.pp_set_tab formatter ();
+  Format.fprintf formatter "Active ";
   Format.pp_set_tab formatter ();
   Format.fprintf formatter "Description@\n";
 
@@ -51,21 +59,31 @@ let pp_print_modules formatter =
     (Format.pp_print_list
        (fun f v ->
          let m = Qsp_syntax.Check.get_module v in
-         pp_print_module f m)
+         pp_module f m)
        ~pp_sep:(fun f () -> Format.pp_force_newline f ()))
-    ll;
+    available_checks;
   Format.pp_close_tbox formatter ();
   Format.pp_print_break formatter 0 0
 
-module Check = Qsp_syntax.Check.Make (struct
-  let t = available_checks
-end)
+let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t =
+  lazy
+    (let module Check = Qsp_syntax.Check.Make (struct
+       let t =
+         List.filter available_checks ~f:(fun v ->
+             let (module A : Qsp_syntax.S.Analyzer) =
+               Qsp_syntax.Check.get_module v
+             in
+             !A.active)
+         |> Array.of_list
+     end) in
+    (module Check))
 
 (** Read the source file until getting a report (the whole location has been
     read properly), or until the first syntax error. 
     *)
 let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
  fun ~ctx lexbuf filters ->
+  let (module Check) = Lazy.force checkers in
   let result =
     Qparser.Analyzer.parse (module Check) lexbuf
     |> Result.map (fun (_, f) ->
@@ -96,7 +114,9 @@ let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
 let default_ctx = { error_nb = 0; warn_nb = 0; debug_nb = 0 }
 
 let () =
-  let file_names, parameters = Args.parse ~list_tests:pp_print_modules in
+  let file_names, parameters =
+    Args.parse ~modules:available_checks ~list_tests:pp_modules
+  in
   let file_name = List.hd file_names in
 
   let ic = Stdlib.open_in_bin file_name in
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index a961738..afb6526 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -104,7 +104,13 @@ end
 
 module type Analyzer = sig
   val identifier : string
+  (** Identifier for the module *)
+
   val description : string
+  (** Short description*)
+
+  val active : bool ref
+  (** Is the test active or not *)
 
   module Expression : Expression
   module Instruction : Instruction with type expression = Expression.t'
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 59eaaf1..c5dfe74 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -110,6 +110,7 @@ end
 module Make (A : App) = struct
   let identifier = "main_checker"
   let description = "Internal module"
+  let active = ref false
 
   (* Global variable for the whole module *)
   let len = Array.length A.t
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index bb56b2f..98c361e 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -2,6 +2,7 @@ open StdLabels
 
 let identifier = "dead_end"
 let description = "Check for dead end in the code"
+let active = ref false
 
 module Expression = struct
   type t = unit
diff --git a/lib/syntax/nested_strings.ml b/lib/syntax/nested_strings.ml
index 37f352c..16ec4ac 100644
--- a/lib/syntax/nested_strings.ml
+++ b/lib/syntax/nested_strings.ml
@@ -2,6 +2,7 @@ open StdLabels
 
 let identifier = "escaped_string"
 let description = "Check for unnecessary use of expression encoded in string"
+let active = ref true
 
 module Expression : S.Expression with type t' = Report.t list = struct
   type t = Report.t list
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index 8444fd9..6f99bbd 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -2,6 +2,7 @@ open StdLabels
 
 let identifier = "tree"
 let description = "Build the AST"
+let active = ref true
 
 module Ast = struct
   type 'a literal = 'a T.literal = Text of string | Expression of 'a list
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 224e029..223633c 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -2,6 +2,7 @@ open StdLabels
 
 let identifier = "type_check"
 let description = "Ensure all the expression are correctly typed"
+let active = ref true
 
 module Helper = struct
   type type_of =