diff options
Diffstat (limited to 'bin')
| -rw-r--r-- | bin/qsp_parser.ml | 132 |
1 files changed, 99 insertions, 33 deletions
diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml index a8ee457..f928d24 100644 --- a/bin/qsp_parser.ml +++ b/bin/qsp_parser.ml @@ -14,17 +14,27 @@ let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list = type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool } +module type T = sig + include module type of Qsp_checks.Dynamics +end + +(** Witness used to extract the values in the module Qsp_checks.Dynamics during + the parsing. *) +let dynamic_context_id : Qsp_checks.Dynamics.context Type.Id.t = Type.Id.make () + (* List all the controls to apply *) let available_checks = [ - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Type_of); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Locations); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Write_only); + Qsp_syntax.Catalog.build ~context_id:dynamic_context_id + (module Qsp_checks.Dynamics); + Qsp_syntax.Catalog.build (module Qsp_checks.Type_of); + Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end); + Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings); + Qsp_syntax.Catalog.build (module Qsp_checks.Locations); + Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test); + Qsp_syntax.Catalog.build (module Qsp_checks.Write_only); ] let pp_module formatter (module A : Qsp_syntax.S.Analyzer) = @@ -72,7 +82,10 @@ let pp_modules formatter = The expression is declared lazy in order to be sure to apply the filters from the command line before. *) -let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t = +let checkers : + (module Qsp_syntax.S.Analyzer + with type context = Qsp_checks.Check.result array) + Lazy.t = lazy (let module Check = Qsp_checks.Check.Make (struct let t = @@ -85,44 +98,94 @@ let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t = end) in (module Check)) +let display_result : + ctx:ctx ref -> + Qparser.Lexbuf.t -> + Args.filters -> + (Report.t list, Report.t) result -> + unit = + fun ~ctx lexbuf filters result -> + match result with + | Error e -> + (* Syntax error, we haven’t been able to run the test *) + let start_position, _ = Qparser.Lexbuf.positions lexbuf in + Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@." + start_position.Lexing.pos_fname Report.pp e; + ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true } + | Ok report -> ( + let report = + List.fold_left report ~init:[] ~f:(filter_report filters) + |> List.sort ~cmp:Report.compare + in + match report with + | [] -> () + | _ -> + (* Display the result *) + let start_position, _ = Qparser.Lexbuf.positions lexbuf in + Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." + start_position.Lexing.pos_fname Report.pp_result report; + + List.iter report ~f:(fun report -> + match report.Report.level with + | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } + | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } + | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb })) + (** Read the source file until getting a report (the whole location has been read properly), or until the first syntax error. The function update the context (list of errors) passed in arguments. *) -let parse_location : type context. +let parse_location : ctx:ctx ref -> - (module Qsp_syntax.S.Analyzer with type context = context) -> - context -> + (module Qsp_syntax.S.Analyzer + with type context = Qsp_checks.Check.result array) -> + Qsp_checks.Check.result array -> Qparser.Lexbuf.t -> Args.filters -> unit = fun ~ctx (module Check) context lexbuf filters -> let result = - Qparser.Analyzer.parse (module Check) lexbuf context - |> Result.map (fun f -> - List.fold_left f.Qparser.Analyzer.report ~init:[] - ~f:(filter_report filters) - |> List.sort ~cmp:Report.compare) + Qparser.Analyzer.parse + (module Check) + Qparser.Analyzer.Location lexbuf context in - match result with - | Ok [] -> () - | Ok report -> - (* Display the result *) - let start_position, _ = Qparser.Lexbuf.positions lexbuf in - Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." - start_position.Lexing.pos_fname Report.pp_result report; - List.iter report ~f:(fun report -> - match report.Report.level with - | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } - | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } - | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb }) - | Error e -> - (* Syntax error, we haven’t been able to run the test *) - let start_position, _ = Qparser.Lexbuf.positions lexbuf in - Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@." - start_position.Lexing.pos_fname Report.pp e; - ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true } + (* Also analyse eache dynamic string identified in the module *) + let result_with_dynamics = + Result.map + (fun r -> + match Qsp_checks.Check.get dynamic_context_id (Array.get context 0) with + | None -> r.Qparser.Analyzer.report + | Some dyn_context -> + let seq : Qsp_checks.Dynamics.text Seq.t = + Qsp_checks.Dynamics.dynamics_string dyn_context + in + Seq.fold_left + (fun r content -> + let text = content.Qsp_checks.Dynamics.content ^ "\n" in + + let lexing = + Sedlexing.Latin1.from_string text + |> Qparser.Lexbuf.from_lexbuf + ~position:(fst content.Qsp_checks.Dynamics.position) + in + + let dyn_report = + Qparser.Analyzer.parse + (module Check) + Qparser.Analyzer.Dynamic lexing context + in + match dyn_report with + | Error e -> + (* Syntax error are not blocking here, but are transformed + into check error *) + e :: r + | Ok dyn_ok_reports -> + dyn_ok_reports.Qparser.Analyzer.report @ r) + r.Qparser.Analyzer.report seq) + result + in + display_result ~ctx lexbuf filters result_with_dynamics let () = let file_names, parameters = @@ -144,6 +207,9 @@ let () = Qsp_checks.Check.get_module t in if C.is_global && !C.active then C.active := false); + + Qsp_checks.Dynamics.active := true; + (* The source file are in UTF-8, and we can use the file line number as we have only a single location. *) ( Sedlexing.Utf8.from_channel ic, |