[python] migrate `infer explore --html` to OCaml, missing GitHub integration

Summary:
Re-implement the generation of an HTML report (with bug traces) in
OCaml.

Kills the --only-show as a side-effect, it is of dubious use since there
is already infer-out/report.txt to get the report list as text. A
follow-up diff adds numbers to the list in infer-out/report.txt for easy
cross-referencing with `infer explore --select 123`.

Reviewed By: skcho

Differential Revision: D20672769

fbshipit-source-id: 39b3a299d

infer/man/man1/infer-explore.txt

@@ -44,10 +44,6 @@ EXPLORE BUGS
            maximum nesting level are skipped. If omitted, all levels are
            shown.
 
-       --only-show
-           Activates: Show the list of reports and exit (Conversely:
-           --no-only-show)
-
        --select N
            Select bug number N. If omitted, prompt for input.
 

infer/man/man1/infer-full.txt

@@ -777,10 +777,6 @@ OPTIONS
            
            See also infer-analyze(1).
 
-       --only-show
-           Activates: Show the list of reports and exit (Conversely:
-           --no-only-show)           See also infer-explore(1).
-
        --perf-profiler-data-file file
            Specify the file containing perf profiler data to read       
     See also infer-analyze(1).

infer/man/man1/infer.txt

@@ -777,10 +777,6 @@ OPTIONS
            
            See also infer-analyze(1).
 
-       --only-show
-           Activates: Show the list of reports and exit (Conversely:
-           --no-only-show)           See also infer-explore(1).
-
        --perf-profiler-data-file file
            Specify the file containing perf profiler data to read       
     See also infer-analyze(1).

infer/src/base/Config.ml

@@ -208,6 +208,8 @@ let racerd_issues_dir_name = "racerd"
 
 let report_condition_always_true_in_clang = false
 
+let report_html_dir = "report.html"
+
 let report_json = "report.json"
 
 (** If true, sanity-check inferred preconditions against Nullable annotations and report
@@ -1650,12 +1652,6 @@ and only_footprint =
   CLOpt.mk_bool ~deprecated:["only_footprint"] ~long:"only-footprint" "Skip the re-execution phase"
 
 
-and only_show =
-  CLOpt.mk_bool ~long:"only-show"
-    ~in_help:InferCommand.[(Explore, manual_explore_bugs)]
-    "Show the list of reports and exit"
-
-
 and oom_threshold =
   CLOpt.mk_int_opt ~long:"oom-threshold"
     "Available memory threshold (in MB) below which multi-worker scheduling throttles back work. \
@@ -2841,8 +2837,6 @@ and only_cheap_debug = !only_cheap_debug
 
 and only_footprint = !only_footprint
 
-and only_show = !only_show
-
 and passthroughs = !passthroughs
 
 and patterns_modeled_expensive = match patterns_modeled_expensive with k, r -> (k, !r)

infer/src/base/Config.mli

@@ -148,6 +148,8 @@ val report_custom_error : bool
 
 val report_force_relative_path : bool
 
+val report_html_dir : string
+
 val report_json : string
 
 val report_nullable_inconsistency : bool
@@ -461,8 +463,6 @@ val only_cheap_debug : bool
 
 val only_footprint : bool
 
-val only_show : bool
-
 val perf_profiler_data_file : string option
 
 val print_active_checkers : bool

infer/src/infer.ml

@@ -208,24 +208,11 @@ let () =
             L.result "CFGs written in %s/*/%s@." Config.captured_dir Config.dotty_frontend_output )
       | false, false ->
           (* explore bug traces *)
-          if Config.html then (
-            let if_some key opt args =
-              match opt with None -> args | Some arg -> key :: string_of_int arg :: args
-            in
-            let if_true key opt args = if not opt then args else key :: args in
-            let if_false key opt args = if opt then args else key :: args in
-            let args =
-              if_some "--max-level" Config.max_nesting
-              @@ if_true "--only-show" Config.only_show
-              @@ if_false "--no-source" Config.source_preview
-              @@ if_true "--html" Config.html
-              @@ if_some "--select" Config.select ["-o"; Config.results_dir]
-            in
-            let prog = Config.lib_dir ^/ "python" ^/ "inferTraceBugs" in
-            if is_error (Unix.waitpid (Unix.fork_exec ~prog ~argv:(prog :: args) ())) then
-              L.external_error
-                "** Error running the reporting script:@\n**   %s %s@\n** See error above@." prog
-                (String.concat ~sep:" " args) )
+          if Config.html then
+            TraceBugs.gen_html_report
+              ~report_json:Config.(results_dir ^/ report_json)
+              ~show_source_context:Config.source_preview ~max_nested_level:Config.max_nesting
+              ~report_html_dir:Config.(results_dir ^/ report_html_dir)
           else
             TraceBugs.explore ~selector_limit:None
               ~report_json:Config.(results_dir ^/ report_json)

infer/src/integration/TraceBugs.ml

@@ -14,6 +14,14 @@ let is_past_limit limit =
   match limit with None -> fun _ -> false | Some limit -> fun n -> n >= limit
 
 
+let has_trace {Jsonbug_t.bug_trace; _} = not (List.is_empty bug_trace)
+
+let with_file_fmt file ~f =
+  Utils.with_file_out file ~f:(fun outc ->
+      let fmt = F.formatter_of_out_channel outc in
+      f fmt ; F.pp_print_flush fmt () )
+
+
 let pp_trace_item ~show_source_context fmt
     Jsonbug_t.{level; filename; line_number; column_number; description} =
   let pp_col_number fmt c = if c >= 0 then F.fprintf fmt ":%d" c in
@@ -23,15 +31,15 @@ let pp_trace_item ~show_source_context fmt
       {Jsonbug_t.file= filename; lnum= line_number; cnum= column_number; enum= -1}
 
 
-let show_issue_with_trace ~show_source_context ~max_nested_level
+let pp_issue_with_trace ~show_source_context ~max_nested_level fmt
     (n_issue, (issue : Jsonbug_t.jsonbug)) =
-  L.result "#%d@\n%a@\n" n_issue TextReport.pp_jsonbug issue ;
-  if List.is_empty issue.bug_trace then L.result "@\nEmpty trace@\n%!"
+  F.fprintf fmt "#%d@\n%a@\n" n_issue TextReport.pp_jsonbug issue ;
+  if List.is_empty issue.bug_trace then F.fprintf fmt "@\nEmpty trace@\n%!"
   else
     List.iter issue.bug_trace ~f:(fun trace_item ->
         (* subtract 1 to get inclusive limits on the nesting level *)
         if not (is_past_limit max_nested_level (trace_item.Jsonbug_t.level - 1)) then
-          L.result "@\n%a" (pp_trace_item ~show_source_context) trace_item )
+          F.fprintf fmt "@\n%a" (pp_trace_item ~show_source_context) trace_item )
 
 
 let user_select_issue ~selector_limit report =
@@ -62,9 +70,11 @@ let user_select_issue ~selector_limit report =
   (n, List.nth_exn report n)
 
 
+let read_report report_json = Atdgen_runtime.Util.Json.from_file Jsonbug_j.read_report report_json
+
 let explore ~selector_limit ~report_txt:_ ~report_json ~show_source_context ~selected
     ~max_nested_level =
-  let report = Atdgen_runtime.Util.Json.from_file Jsonbug_j.read_report report_json in
+  let report = read_report report_json in
   let issue_to_display =
     match (selected, report) with
     | Some n, _ -> (
@@ -87,7 +97,51 @@ let explore ~selector_limit ~report_txt:_ ~report_json ~show_source_context ~sel
         (* user prompt *)
         Some (user_select_issue ~selector_limit report)
   in
-  Option.iter issue_to_display
-    ~f:
-      ( L.result "@\n" ;
-        show_issue_with_trace ~show_source_context ~max_nested_level )
+  Option.iter issue_to_display ~f:(fun issue ->
+      L.result "@\n%a" (pp_issue_with_trace ~show_source_context ~max_nested_level) issue )
+
+
+let trace_path_of_bug_number ~traces_dir i = traces_dir ^/ Printf.sprintf "bug_%d.txt" i
+
+let pp_html_index ~traces_dir fmt report =
+  let pp_issue_entry fmt issue_i =
+    let pp_trace_uri fmt (i, (issue : Jsonbug_t.jsonbug)) =
+      if has_trace issue then
+        F.fprintf fmt "<a href=\"%s\">trace</a>" (trace_path_of_bug_number ~traces_dir i)
+      else F.pp_print_string fmt "no trace"
+    in
+    F.fprintf fmt "<li>%a (%a)</li>" TextReport.pp_jsonbug (snd issue_i) pp_trace_uri issue_i
+  in
+  let pp_issues_list fmt report =
+    F.fprintf fmt "<ol start=\"0\">@\n" ;
+    List.iteri report ~f:(fun i issue -> pp_issue_entry fmt (i, issue)) ;
+    F.fprintf fmt "@\n</ol>"
+  in
+  F.fprintf fmt
+    {|<html>
+<head>
+<title>Infer found %d issues</title>
+</head>
+<body>
+<h2>List of issues found</h2>
+%a
+</body>
+</html>|}
+    (List.length report) pp_issues_list report
+
+
+let gen_html_report ~show_source_context ~max_nested_level ~report_json ~report_html_dir =
+  (* delete previous report if present *)
+  Utils.rmtree report_html_dir ;
+  Utils.create_dir report_html_dir ;
+  let traces_dir = "traces" in
+  Utils.create_dir (report_html_dir ^/ traces_dir) ;
+  let report = read_report report_json in
+  List.iteri report ~f:(fun i issue ->
+      if has_trace issue then
+        let file = report_html_dir ^/ trace_path_of_bug_number ~traces_dir i in
+        with_file_fmt file ~f:(fun fmt ->
+            pp_issue_with_trace ~show_source_context ~max_nested_level fmt (i, issue) ) ) ;
+  let report_html = report_html_dir ^/ "index.html" in
+  with_file_fmt report_html ~f:(fun fmt -> pp_html_index ~traces_dir fmt report) ;
+  L.result "Saved HTML report in '%s'@." report_html

infer/src/integration/TraceBugs.mli

@@ -14,3 +14,10 @@ val explore :
   -> selected:int option
   -> max_nested_level:int option
   -> unit
+
+val gen_html_report :
+     show_source_context:bool
+  -> max_nested_level:int option
+  -> report_json:string
+  -> report_html_dir:string
+  -> unit

infer/tests/build_systems/tracebugs/Makefile

@@ -34,15 +34,9 @@ test3: infer-out/report.json
 	$(INFER_BIN) explore -o infer-out \
 	  --select 0 --no-source-preview)
 
-.PHONY: test4
-test4: infer-out/report.json
-	$(QUIET)$(call silent_on_success,Testing infer-explore: --only-show,\
-	$(INFER_BIN) explore -o infer-out \
-	  --only-show)
-
 
 .PHONY: print
-print: test1 test2 test3 test4
+print: test1 test2 test3
 
 .PHONY: test
 test: print