[pp] move utility function from Sil to Pp

Summary:
Part of making Sil.ml about SIL only.

In order to not introduce a dependency istd/Pp -> base/Config, the
utilities in Pp don't know when to introduce "diff" colours. Fix it by
wrapping them in Sil using the Config option. (we may want to just kill
that option at some point).

Similarly, move stuff from Io_infer to Pp.

Reviewed By: ngorogiannis

Differential Revision: D19158534

fbshipit-source-id: 8110cb7f9

infer/src/IR/DecompiledExp.ml

@@ -141,7 +141,7 @@ let pp_vpath pe fmt vpath =
   let pp fmt = function Some de -> pp fmt de | None -> () in
   if Pp.equal_print_kind pe.Pp.kind Pp.HTML then
     let pp f vpath = F.fprintf f "{vpath: %a}" pp vpath in
-    Io_infer.Html.with_color Orange pp fmt vpath
+    Pp.html_with_color Orange pp fmt vpath
   else pp fmt vpath
 
 

infer/src/IR/Io_infer.ml

@@ -98,10 +98,6 @@ h1 { font-size:14pt }
   (** Print a horizontal line *)
   let pp_hline fmt () = F.pp_print_string fmt "\n<hr width=\"100%\">\n"
 
-  let with_color color pp f x =
-    F.fprintf f "<span class='%s'>%a</span>" (Pp.color_string color) pp x
-
-
   let pp_link ?(name = None) ?(pos = None) ~path fmt text =
     let link_str =
       let escaped_path = List.map ~f:Escape.escape_url path in

infer/src/IR/Io_infer.mli

@@ -66,9 +66,6 @@ module Html : sig
     -> int * int * int
     -> unit
   (** Print an html link given node id and session *)
-
-  val with_color : Pp.color -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
-  (** Print using color *)
 end
 
 (** Create and print xml trees *)

infer/src/IR/Sil.ml

@@ -232,36 +232,11 @@ end)
 
 (** {2 Pretty Printing} *)
 
-let color_wrapper pe ppf x ~f =
+let color_wrapper ~f = if Config.print_using_diff then Pp.color_wrapper ~f else f
-  if Config.print_using_diff && pe.Pp.kind <> Pp.TEXT then
-    let color = pe.Pp.cmap_norm (Obj.repr x) in
-    if color <> pe.Pp.color then
-      let pe' =
-        if Pp.equal_color color Pp.Red then
-          (* All subexpressions red *)
-          Pp.{pe with cmap_norm= colormap_red; color= Red}
-        else Pp.{pe with color}
-      in
-      Io_infer.Html.with_color color (f pe') ppf x
-    else f pe ppf x
-  else f pe ppf x
-
 
-(** Print a sequence with difference mode if enabled. *)
+let pp_seq_diff pp print_env fmt l =
-let pp_seq_diff pp pe0 f =
+  if Config.print_using_diff then Pp.comma_seq_diff pp print_env fmt l
-  if not Config.print_using_diff then Pp.comma_seq pp f
+  else Pp.comma_seq ~print_env pp fmt l
-  else
-    let rec doit = function
-      | [] ->
-          ()
-      | [x] ->
-          color_wrapper pe0 f x ~f:(fun _pe -> pp)
-      | x :: l ->
-          color_wrapper pe0 f x ~f:(fun _pe -> pp) ;
-          F.pp_print_string f ", " ;
-          doit l
-    in
-    doit
 
 
 (** Pretty print an expression. *)
@@ -803,7 +778,7 @@ let update_inst inst_old inst_new =
 (** describe an instrumentation with a string *)
 let pp_inst_if_trace pe f inst =
   if Config.trace_error then
-    if Pp.equal_print_kind pe.Pp.kind Pp.HTML then Io_infer.Html.with_color Orange pp_inst f inst
+    if Pp.equal_print_kind pe.Pp.kind Pp.HTML then Pp.html_with_color Orange pp_inst f inst
     else F.fprintf f "%s%a%s" (Binop.str pe Lt) pp_inst inst (Binop.str pe Gt)
 
 

infer/src/IR/Sil.mli

@@ -259,9 +259,6 @@ val add_with_block_parameters_flag : instr -> instr
 
 (** {2 Pretty Printing} *)
 
-val color_wrapper : Pp.env -> F.formatter -> 'a -> f:(Pp.env -> F.formatter -> 'a -> unit) -> unit
-(** Wraps a printing function with an updated printenv when using diff printing *)
-
 val pp_exp_printenv : ?print_types:bool -> Pp.env -> F.formatter -> Exp.t -> unit
 (** Pretty print an expression. *)
 

infer/src/backend/Summary.ml

@@ -121,7 +121,7 @@ let pp_text fmt summary =
 
 let pp_html source fmt summary =
   F.pp_force_newline fmt () ;
-  Io_infer.Html.with_color Black pp_no_stats_specs fmt summary ;
+  Pp.html_with_color Black pp_no_stats_specs fmt summary ;
   F.fprintf fmt "<br />%a<br />@\n" Stats.pp summary.stats ;
   Errlog.pp_html source [] fmt (get_err_log summary) ;
   Io_infer.Html.pp_hline fmt () ;

infer/src/biabduction/BiabductionSummary.ml

@@ -269,7 +269,7 @@ let pp_spec0 pe num_opt fmt spec =
       F.fprintf fmt "--------------------------- %a ---------------------------@\n" pp_num_opt
         num_opt ;
       F.fprintf fmt "PRE:@\n" ;
-      Io_infer.Html.with_color Blue (Prop.pp_prop (Pp.html Blue)) fmt pre ;
+      Pp.html_with_color Blue (Prop.pp_prop (Pp.html Blue)) fmt pre ;
       F.pp_force_newline fmt () ;
       Propgraph.pp_proplist pe_post "POST" (pre, true) fmt post_list ;
       F.pp_print_string fmt "----------------------------------------------------------------"

infer/src/biabduction/Prop.ml

@@ -113,7 +113,7 @@ let pp_texp_simple pe =
 
 (** Pretty print a pointsto representing a stack variable as an equality *)
 let pp_hpred_stackvar =
-  Sil.color_wrapper ~f:(fun pe f (hpred : Sil.hpred) ->
+  Pp.color_wrapper ~f:(fun pe f (hpred : Sil.hpred) ->
       match hpred with
       | Hpointsto (Exp.Lvar pvar, se, te) ->
           let pe' =
@@ -139,7 +139,7 @@ let pp_sub pe f sub =
 let d_sub (sub : Sil.subst) = L.d_pp_with_pe pp_sub sub
 
 let pp_sub_entry =
-  Sil.color_wrapper ~f:(fun pe f entry ->
+  Pp.color_wrapper ~f:(fun pe f entry ->
       let x, e = entry in
       F.fprintf f "%a = %a" Ident.pp x (Sil.pp_exp_printenv pe) e )
 
@@ -313,11 +313,7 @@ let pp_prop pe0 f prop =
     F.fprintf f "%a%a%a%a" pp_pure () (pp_sigma_simple pe env) prop.sigma
       (pp_footprint_simple pe env) prop pp_predicates ()
   in
-  match pe0.Pp.kind with
+  match pe0.Pp.kind with HTML -> Pp.html_with_color Blue do_print f () | TEXT -> do_print f ()
-  | Pp.HTML ->
-      Io_infer.Html.with_color Blue do_print f ()
-  | TEXT ->
-      do_print f ()
 
 
 let pp_prop_with_typ pe f p = pp_prop {pe with opt= SIM_WITH_TYP} f p

infer/src/istd/Pp.ml

@@ -100,6 +100,25 @@ let color_string = function
       "color_red"
 
 
+let html_with_color color pp f x =
+  F.fprintf f "<span class='%s'>%a</span>" (color_string color) pp x
+
+
+let color_wrapper pe ppf x ~f =
+  match pe.kind with
+  | HTML when pe.cmap_norm (Obj.repr x) <> pe.color ->
+      let color = pe.cmap_norm (Obj.repr x) in
+      let pe' =
+        if equal_color color Red then
+          (* All subexpressions red *)
+          {pe with cmap_norm= colormap_red; color= Red}
+        else {pe with color}
+      in
+      html_with_color color (f pe') ppf x
+  | _ ->
+      f pe ppf x
+
+
 let seq ?(print_env = text) ?sep:(sep_text = " ") ?(sep_html = sep_text) pp =
   let rec aux f = function
     | [] ->
@@ -118,6 +137,20 @@ let comma_seq ?print_env pp f l = seq ?print_env ~sep:"," pp f l
 
 let semicolon_seq ?print_env pp f l = seq ?print_env ~sep:"; " pp f l
 
+let comma_seq_diff pp pe0 f =
+  let rec doit = function
+    | [] ->
+        ()
+    | [x] ->
+        color_wrapper pe0 f x ~f:(fun _pe -> pp)
+    | x :: l ->
+        color_wrapper pe0 f x ~f:(fun _pe -> pp) ;
+        F.pp_print_string f ", " ;
+        doit l
+  in
+  doit
+
+
 (** Print the current time and date in a format similar to the "date" command *)
 let current_time f () =
   let tm = Unix.localtime (Unix.time ()) in

infer/src/istd/Pp.mli

@@ -45,12 +45,11 @@ val set_obj_sub : env -> ('a -> 'a) -> env
 (** Set the object substitution, which is supposed to preserve the type. Currently only used for a
     map from (identifier) expressions to the program var containing them *)
 
-val colormap_red : colormap
-(** red colormap *)
-
 val extend_colormap : env -> Obj.t -> color -> env
 (** Extend the normal colormap for the given object with the given color *)
 
+val color_wrapper : env -> F.formatter -> 'a -> f:(env -> F.formatter -> 'a -> unit) -> unit
+
 val text : env
 (** Default text print environment *)
 
@@ -63,6 +62,8 @@ val html : color -> env
 val color_string : color -> string
 (** string representation of colors *)
 
+val html_with_color : color -> (F.formatter -> 'a -> unit) -> F.formatter -> 'a -> unit
+
 val option : (F.formatter -> 'a -> unit) -> F.formatter -> 'a option -> unit
 
 val cli_args : F.formatter -> string list -> unit
@@ -85,6 +86,8 @@ val seq :
 val comma_seq : ?print_env:env -> (F.formatter -> 'a -> unit) -> F.formatter -> 'a list -> unit
 (** Pretty print a comma-separated sequence. *)
 
+val comma_seq_diff : (F.formatter -> 'a -> unit) -> env -> F.formatter -> 'a list -> unit
+
 val semicolon_seq : ?print_env:env -> (F.formatter -> 'a -> unit) -> F.formatter -> 'a list -> unit
 (** Pretty print a ;-separated sequence *)