diff options
| -rw-r--r-- | bin/args.ml | 49 | ||||
| -rw-r--r-- | bin/args.mli | 5 | ||||
| -rw-r--r-- | bin/qsp_parser.ml | 46 | ||||
| -rw-r--r-- | lib/syntax/S.ml | 6 | ||||
| -rw-r--r-- | lib/syntax/check.ml | 1 | ||||
| -rw-r--r-- | lib/syntax/dead_end.ml | 1 | ||||
| -rw-r--r-- | lib/syntax/nested_strings.ml | 1 | ||||
| -rw-r--r-- | lib/syntax/tree.ml | 1 | ||||
| -rw-r--r-- | lib/syntax/type_of.ml | 1 |
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 = |