Some pp functions

Reviewed By: jeremydubreil

Differential Revision: D12840576

fbshipit-source-id: 0beebcc63

infer/src/IR/Ident.ml

@@ -220,22 +220,21 @@ let create_path pathstring =
 
 (** {2 Pretty Printing} *)
 
-(** Convert an identifier to a string. *)
-let to_string id =
-  if has_kind id KNone then "_"
+(** Pretty print an identifier. *)
+let pp f id =
+  if has_kind id KNone then F.pp_print_char f '_'
   else
     let base_name = name_to_string id.name in
     let prefix = if has_kind id KFootprint then "@" else if has_kind id KNormal then "" else "_" in
-    let suffix = "$" ^ string_of_int id.stamp in
-    prefix ^ base_name ^ suffix
+    F.fprintf f "%s%s$%d" prefix base_name id.stamp
+
 
+(** Convert an identifier to a string. *)
+let to_string id = F.asprintf "%a" pp id
 
 (** Pretty print a name. *)
 let pp_name f name = F.pp_print_string f (name_to_string name)
 
-(** Pretty print an identifier. *)
-let pp f id = F.pp_print_string f (to_string id)
-
 (** pretty printer for lists of identifiers *)
 let pp_list = Pp.comma_seq pp
 

infer/src/IR/Sil.ml

@@ -638,37 +638,39 @@ let inst_new_loc loc inst =
       Ireturn_from_call loc.Location.line
 
 
-(** return a string representing the inst *)
-let inst_to_string inst =
-  let zero_flag_to_string = function Some true -> "(z)" | _ -> "" in
-  let null_case_flag_to_string ncf = if ncf then "(ncf)" else "" in
+(** pretty-print an inst *)
+let pp_inst f inst =
+  let pp_zero_flag f = function Some true -> F.pp_print_string f "(z)" | _ -> () in
+  let pp_null_case_flag f ncf = if ncf then F.pp_print_string f "(ncf)" in
   match inst with
   | Iabstraction ->
-      "abstraction"
+      F.pp_print_string f "abstraction"
   | Iactual_precondition ->
-      "actual_precondition"
+      F.pp_print_string f "actual_precondition"
   | Ialloc ->
-      "alloc"
+      F.pp_print_string f "alloc"
   | Iformal (zf, ncf) ->
-      "formal" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf
+      F.fprintf f "formal%a%a" pp_zero_flag zf pp_null_case_flag ncf
   | Iinitial ->
-      "initial"
+      F.pp_print_string f "initial"
   | Ilookup ->
-      "lookup"
+      F.pp_print_string f "lookup"
   | Inone ->
-      "none"
+      F.pp_print_string f "none"
   | Inullify ->
-      "nullify"
+      F.pp_print_string f "nullify"
   | Irearrange (zf, ncf, n, _) ->
-      "rearrange:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n
+      F.fprintf f "rearrange:%a%a%d" pp_zero_flag zf pp_null_case_flag ncf n
   | Itaint ->
-      "taint"
+      F.pp_print_string f "taint"
   | Iupdate (zf, ncf, n, _) ->
-      "update:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n
+      F.fprintf f "update:%a%a%d" pp_zero_flag zf pp_null_case_flag ncf n
   | Ireturn_from_call n ->
-      "return_from_call: " ^ string_of_int n
+      F.fprintf f "return_from_call: %d" n
 
 
+let inst_to_string inst = F.asprintf "%a" pp_inst inst
+
 exception JoinFail
 
 (** join of instrumentations, can raise JoinFail *)
@@ -779,14 +781,13 @@ let update_inst inst_old inst_new =
 
 
 (** describe an instrumentation with a string *)
-let pp_inst pe f inst =
-  let str = inst_to_string inst in
-  if Pp.equal_print_kind pe.Pp.kind Pp.HTML then
-    F.fprintf f " %a%s%a" Io_infer.Html.pp_start_color Pp.Orange str Io_infer.Html.pp_end_color ()
-  else F.fprintf f "%s%s%s" (Binop.str pe Lt) str (Binop.str pe Gt)
-
+let pp_inst_if_trace pe f inst =
+  if Config.trace_error then
+    if Pp.equal_print_kind pe.Pp.kind Pp.HTML then
+      F.fprintf f " %a%a%a" Io_infer.Html.pp_start_color Pp.Orange pp_inst inst
+        Io_infer.Html.pp_end_color ()
+    else F.fprintf f "%s%a%s" (Binop.str pe Lt) pp_inst inst (Binop.str pe Gt)
 
-let pp_inst_if_trace pe f inst = if Config.trace_error then pp_inst pe f inst
 
 (** pretty print a strexp with an optional predicate env *)
 let rec pp_sexp_env pe0 envo f se =

infer/src/IR/Sil.mli

@@ -303,6 +303,9 @@ val d_atom : atom -> unit
 val inst_to_string : inst -> string
 (** return a string representing the inst *)
 
+val pp_inst : F.formatter -> inst -> unit
+(** pretty-print an inst *)
+
 val pp_sexp : Pp.env -> F.formatter -> strexp -> unit
 (** Pretty print a strexp. *)
 

infer/src/biabduction/Paths.ml

@@ -381,23 +381,16 @@ end = struct
     Option.value_exn max_rep_opt
 
 
-  let stats_string path =
+  let pp_stats f path =
     Invariant.compute_stats true (fun _ -> true) path ;
     let repetitions, node = repetitions path in
-    let str =
-      "linear paths: "
-      ^ string_of_float (Invariant.get_stats path).linear_num
-      ^ " max length: "
-      ^ string_of_int (Invariant.get_stats path).max_length
-      ^ " has repetitions: " ^ string_of_int repetitions ^ " of node "
-      ^ string_of_int (Procdesc.Node.get_id node :> int)
-    in
-    Invariant.reset_stats path ; str
-
+    F.fprintf f "linear paths: %f max length: %d has repetitions: %d of node %a"
+      (Invariant.get_stats path).linear_num (Invariant.get_stats path).max_length repetitions
+      Procdesc.Node.pp node ;
+    Invariant.reset_stats path
 
-  let pp_stats fmt path = F.pp_print_string fmt (stats_string path)
 
-  let d_stats path = L.d_str (stats_string path)
+  let d_stats path = L.d_str (F.asprintf "%a" pp_stats path)
 
   module PathMap = Caml.Map.Make (struct
     type nonrec t = t

infer/src/biabduction/RetainCycles.ml

@@ -238,7 +238,7 @@ let report_cycle tenv summary prop =
   (* When there is a cycle in objc we ignore it only if it's empty or it has weak or
      unsafe_unretained fields.  Otherwise we report a retain cycle. *)
   let cycles = get_retain_cycles tenv prop in
-  RetainCyclesType.Set.iter RetainCyclesType.print_cycle cycles ;
+  RetainCyclesType.Set.iter RetainCyclesType.d_retain_cycle cycles ;
   if not (RetainCyclesType.Set.is_empty cycles) then (
     RetainCyclesType.Set.iter
       (fun cycle ->

infer/src/biabduction/RetainCyclesType.ml

@@ -94,33 +94,29 @@ let is_exp_null node =
   match node with Object obj -> Exp.is_null_literal obj.rc_from.rc_node_exp | Block _ -> false
 
 
-let retain_cycle_node_to_string (node : retain_cycle_node) =
-  Format.sprintf "%s : %s" (Exp.to_string node.rc_node_exp) (Typ.to_string node.rc_node_typ)
+let pp_retain_cycle_node f (node : retain_cycle_node) =
+  Format.fprintf f "%a : %a" Exp.pp node.rc_node_exp (Typ.pp_full Pp.text) node.rc_node_typ
 
 
-let retain_cycle_field_to_string (field : retain_cycle_field) =
-  Format.sprintf "%s[%s]"
-    (Typ.Fieldname.to_string field.rc_field_name)
-    (Sil.inst_to_string field.rc_field_inst)
+let pp_retain_cycle_field f (field : retain_cycle_field) =
+  Format.fprintf f "%a[%a]" Typ.Fieldname.pp field.rc_field_name Sil.pp_inst field.rc_field_inst
 
 
-let retain_cycle_edge_to_string (edge : retain_cycle_edge) =
+let pp_retain_cycle_edge f (edge : retain_cycle_edge) =
   match edge with
   | Object obj ->
-      Format.sprintf "%s ->{%s}"
-        (retain_cycle_node_to_string obj.rc_from)
-        (retain_cycle_field_to_string obj.rc_field)
+      Format.fprintf f "%a ->{%a}" pp_retain_cycle_node obj.rc_from pp_retain_cycle_field
+        obj.rc_field
   | Block _ ->
-      Format.sprintf "a block"
+      Format.pp_print_string f "a block"
 
 
-let retain_cycle_to_string cycle =
-  "Cycle= \n\t"
-  ^ String.concat ~sep:"->" (List.map ~f:retain_cycle_edge_to_string cycle.rc_elements)
+let d_retain_cycle cycle =
+  Logging.d_strln "Cycle=" ;
+  Logging.d_strln
+    (Format.asprintf "\t%a" (Pp.seq ~sep:"->" pp_retain_cycle_edge) cycle.rc_elements)
 
 
-let print_cycle cycle = Logging.d_strln (retain_cycle_to_string cycle)
-
 let find_minimum_element cycle =
   List.reduce_exn cycle.rc_elements ~f:(fun el1 el2 ->
       if compare_retain_cycle_edge el1 el2 < 0 then el1 else el2 )

infer/src/biabduction/RetainCyclesType.mli

@@ -22,7 +22,7 @@ type t = {rc_head: retain_cycle_edge; rc_elements: retain_cycle_edge list}
 (** Set for retain cycles. *)
 module Set : Caml.Set.S with type elt = t
 
-val print_cycle : t -> unit
+val d_retain_cycle : t -> unit
 
 val create_cycle : retain_cycle_edge list -> t option
 (** Creates a cycle if the list is non-empty *)