1 files changed, 92 insertions, 0 deletions
diff --git a/bin/checklist.ml b/bin/checklist.ml
new file mode 100644
index 0000000..3eb6b93
--- /dev/null
+++ b/bin/checklist.ml
@@ -0,0 +1,92 @@
+open StdLabels
+
+(** 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 =
+  [
+    Qsp_syntax.Identifier.build ~context_id:dynamic_context_id
+      (module Qsp_checks.Dynamics);
+    Qsp_syntax.Identifier.build (module Qsp_checks.Type_of);
+    Qsp_syntax.Identifier.build (module Qsp_checks.Dead_end);
+    Qsp_syntax.Identifier.build (module Qsp_checks.Nested_strings);
+    Qsp_syntax.Identifier.build (module Qsp_checks.Locations);
+    Qsp_syntax.Identifier.build (module Qsp_checks.Dup_test);
+    Qsp_syntax.Identifier.build (module Qsp_checks.Write_only);
+  ]
+
+(** Get all the tests to apply.
+
+    The expression is declared lazy in order to be sure to apply the filters
+    from the command line before. *)
+let checkers :
+    (module Qsp_syntax.Analyzer.T
+       with type context = Qsp_checks.Check.result array)
+    Lazy.t =
+  lazy
+    (let module Check = Qsp_checks.Check.Make (struct
+       let t =
+         List.filter available_checks ~f:(fun v ->
+             let (module A : Qsp_syntax.Analyzer.T) =
+               Qsp_syntax.Identifier.get_module v
+             in
+             !A.active)
+         |> Array.of_list
+     end) in
+    (module Check))
+
+let get_report :
+    (module Qsp_syntax.Analyzer.T
+       with type context = Qsp_checks.Check.result array) ->
+    Qsp_checks.Check.result array ->
+    Qparser.Lexbuf.t ->
+    (Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result =
+ fun (module Check) context lexbuf ->
+  let result =
+    Qparser.Analyzer.parse
+      (module Check)
+      Qparser.Analyzer.Location lexbuf context
+  in
+
+  (* Also analyse eache dynamic string identified in the module *)
+  Result.map
+    (fun r ->
+      let found_report =
+        Array.find_map context ~f:(fun value ->
+            Qsp_checks.Check.get dynamic_context_id value)
+      in
+
+      match found_report 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