[sledge] Add Set.Provide_pp

Reviewed By: jvillard

Differential Revision: D25756559

fbshipit-source-id: fa55750d9

sledge/nonstdlib/set.ml

@@ -118,11 +118,20 @@ end) : S with type elt = Elt.t = struct
   let to_iter = S.to_iter
   let of_iter = S.of_iter
 
-  let pp ?pre ?suf ?(sep = (",@ " : (unit, unit) fmt)) pp_elt fs x =
+  let pp_full ?pre ?suf ?(sep = (",@ " : (unit, unit) fmt)) pp_elt fs x =
     List.pp ?pre ?suf sep pp_elt fs (S.elements x)
 
-  let pp_diff pp_elt fs (xs, ys) =
-    let lose = diff xs ys and gain = diff ys xs in
-    if not (is_empty lose) then Format.fprintf fs "-- %a" (pp pp_elt) lose ;
-    if not (is_empty gain) then Format.fprintf fs "++ %a" (pp pp_elt) gain
+  module Provide_pp (Elt : sig
+    type t = elt
+
+    val pp : t pp
+  end) =
+  struct
+    let pp = pp_full Elt.pp
+
+    let pp_diff fs (xs, ys) =
+      let lose = diff xs ys and gain = diff ys xs in
+      if not (is_empty lose) then Format.fprintf fs "-- %a" pp lose ;
+      if not (is_empty gain) then Format.fprintf fs "++ %a" pp gain
+  end
 end

sledge/nonstdlib/set_intf.ml

@@ -25,6 +25,27 @@ module type S = sig
   end
   with type t := t
 
+  (** {1 Pretty-print} *)
+
+  val pp_full :
+       ?pre:(unit, unit) fmt
+    -> ?suf:(unit, unit) fmt
+    -> ?sep:(unit, unit) fmt
+    -> elt pp
+    -> t pp
+
+  module Provide_pp (_ : sig
+    type t = elt
+
+    val pp : t pp
+  end) : sig
+    type t
+
+    val pp : t pp
+    val pp_diff : (t * t) pp
+  end
+  with type t := t
+
   (** {1 Construct} *)
 
   val empty : t
@@ -75,15 +96,4 @@ module type S = sig
 
   val to_iter : t -> elt iter
   val of_iter : elt iter -> t
-
-  (** {1 Pretty-print} *)
-
-  val pp :
-       ?pre:(unit, unit) fmt
-    -> ?suf:(unit, unit) fmt
-    -> ?sep:(unit, unit) fmt
-    -> elt pp
-    -> t pp
-
-  val pp_diff : elt pp -> (t * t) pp
 end

sledge/src/control.ml

@@ -211,21 +211,23 @@ module Make (Opts : Domain_intf.Opts) (Dom : Domain_intf.Dom) = struct
       type elt = {depth: int; edge: Edge.t; state: Dom.t; depths: Depths.t}
       [@@deriving compare, sexp_of]
 
-      module Elts = Set.Make (struct
+      module Elt = struct
         type t = elt [@@deriving compare, sexp_of]
-      end)
 
-      type t = {queue: elt FHeap.t; removed: Elts.t}
+        let pp ppf {depth; edge} =
+          Format.fprintf ppf "%i: %a" depth Edge.pp edge
+      end
 
-      let pp_elt ppf {depth; edge} =
-        Format.fprintf ppf "%i: %a" depth Edge.pp edge
+      module Elts = Set.Make (Elt)
+
+      type t = {queue: elt FHeap.t; removed: Elts.t}
 
       let pp ppf {queue; removed} =
         let rev_elts =
           FHeap.fold queue ~init:[] ~f:(fun rev_elts elt ->
               if Elts.mem elt removed then rev_elts else elt :: rev_elts )
         in
-        Format.fprintf ppf "@[%a@]" (List.pp " ::@ " pp_elt)
+        Format.fprintf ppf "@[%a@]" (List.pp " ::@ " Elt.pp)
           (List.rev rev_elts)
 
       let create () =

sledge/src/fol/exp.ml

@@ -193,15 +193,15 @@ module Term = struct
      one step. *)
   module T = struct
     type t = exp [@@deriving compare, equal, sexp]
+
+    let ppx = ppx
+    let pp = pp
   end
 
   include T
   module Set = Set.Make (T)
   module Map = Map.Make (T)
 
-  let ppx = ppx
-  let pp = pp
-
   (* variables *)
 
   let var v = `Trm (v : var :> trm)

sledge/src/fol/fml.ml

@@ -43,11 +43,11 @@ let ppx strength fs fml =
       else pp_arith_op p_c op n_d
     in
     let pp_join sep pos neg =
-      pf "(%a%t%a)" (Set.pp ~sep pp) pos
+      pf "(%a%t%a)" (Set.pp_full ~sep pp) pos
         (fun ppf ->
           if (not (Set.is_empty pos)) && not (Set.is_empty neg) then
             Format.fprintf ppf sep )
-        (Set.pp ~sep (fun fs fml -> pp fs (_Not fml)))
+        (Set.pp_full ~sep (fun fs fml -> pp fs (_Not fml)))
         neg
     in
     match fml with

sledge/src/fol/var0.ml

@@ -9,23 +9,28 @@ open Var_intf
 
 (** Variables, parameterized over their representation *)
 module Make (T : REPR) = struct
-  include T
-
-  type nonrec strength = t strength
-
-  let ppx strength ppf v =
-    let id = id v in
-    let name = name v in
-    let pp_id ppf id = if id <> 0 then Format.fprintf ppf "_%d" id in
-    match strength v with
-    | None ->
-        if id = 0 then Trace.pp_styled `Bold "%%%s" ppf name
-        else Format.fprintf ppf "%%%s%a" name pp_id id
-    | Some `Universal -> Trace.pp_styled `Bold "%%%s%a" ppf name pp_id id
-    | Some `Existential -> Trace.pp_styled `Cyan "%%%s%a" ppf name pp_id id
-    | Some `Anonymous -> Trace.pp_styled `Cyan "_" ppf
+  module T = struct
+    include T
+
+    type nonrec strength = t strength
+
+    let ppx strength ppf v =
+      let id = id v in
+      let name = name v in
+      let pp_id ppf id = if id <> 0 then Format.fprintf ppf "_%d" id in
+      match strength v with
+      | None ->
+          if id = 0 then Trace.pp_styled `Bold "%%%s" ppf name
+          else Format.fprintf ppf "%%%s%a" name pp_id id
+      | Some `Universal -> Trace.pp_styled `Bold "%%%s%a" ppf name pp_id id
+      | Some `Existential ->
+          Trace.pp_styled `Cyan "%%%s%a" ppf name pp_id id
+      | Some `Anonymous -> Trace.pp_styled `Cyan "_" ppf
+
+    let pp = ppx (fun _ -> None)
+  end
 
-  let pp = ppx (fun _ -> None)
+  include T
 
   module Map = struct
     include NS.Map.Make (T)
@@ -33,13 +38,12 @@ module Make (T : REPR) = struct
   end
 
   module Set = struct
-    let pp_t = pp
-
-    include NS.Set.Make (T)
+    module S = NS.Set.Make (T)
+    include S
     include Provide_of_sexp (T)
+    include Provide_pp (T)
 
-    let ppx strength vs = pp (ppx strength) vs
-    let pp vs = pp pp_t vs
+    let ppx strength vs = S.pp_full (ppx strength) vs
 
     let pp_xs fs xs =
       if not (is_empty xs) then

sledge/src/fol/var_intf.ml

@@ -36,6 +36,7 @@ module type VAR = sig
     val ppx : strength -> t pp
     val pp : t pp
     val pp_xs : t pp
+    val pp_diff : (t * t) pp
   end
 
   val id : t -> int

sledge/src/llair/exp.ml

@@ -73,6 +73,89 @@ module T = struct
     | Ap3 of op3 * Typ.t * t * t * t
     | ApN of opN * Typ.t * t iarray
   [@@deriving compare, equal, hash, sexp]
+
+  let demangle = ref (fun _ -> None)
+
+  let pp_demangled ppf name =
+    match !demangle name with
+    | Some demangled when not (String.equal name demangled) ->
+        Format.fprintf ppf "“%s”" demangled
+    | _ -> ()
+
+  let pp_op2 fs op =
+    let pf fmt = Format.fprintf fs fmt in
+    match op with
+    | Eq -> pf "="
+    | Dq -> pf "@<1>≠"
+    | Gt -> pf ">"
+    | Ge -> pf "@<1>≥"
+    | Lt -> pf "<"
+    | Le -> pf "@<1>≤"
+    | Ugt -> pf "u>"
+    | Uge -> pf "@<2>u≥"
+    | Ult -> pf "u<"
+    | Ule -> pf "@<2>u≤"
+    | Ord -> pf "ord"
+    | Uno -> pf "uno"
+    | Add -> pf "+"
+    | Sub -> pf "-"
+    | Mul -> pf "@<1>×"
+    | Div -> pf "/"
+    | Udiv -> pf "udiv"
+    | Rem -> pf "rem"
+    | Urem -> pf "urem"
+    | And -> pf "&&"
+    | Or -> pf "||"
+    | Xor -> pf "xor"
+    | Shl -> pf "shl"
+    | Lshr -> pf "lshr"
+    | Ashr -> pf "ashr"
+    | Update idx -> pf "[_|%i→_]" idx
+
+  let rec pp fs exp =
+    let pf fmt =
+      Format.pp_open_box fs 2 ;
+      Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs fmt
+    in
+    match exp with
+    | Reg {name} -> pf "%%%s" name
+    | Global {name} -> pf "%@%s%a" name pp_demangled name
+    | Function {name} -> pf "&%s%a" name pp_demangled name
+    | Label {name} -> pf "%s" name
+    | Integer {data; typ= Pointer _} when Z.equal Z.zero data -> pf "null"
+    | Integer {data} -> Trace.pp_styled `Magenta "%a" fs Z.pp data
+    | Float {data} -> pf "%s" data
+    | Ap1 (Signed {bits}, dst, arg) ->
+        pf "((%a)(s%i)@ %a)" Typ.pp dst bits pp arg
+    | Ap1 (Unsigned {bits}, dst, arg) ->
+        pf "((%a)(u%i)@ %a)" Typ.pp dst bits pp arg
+    | Ap1 (Convert {src}, dst, arg) ->
+        pf "((%a)(%a)@ %a)" Typ.pp dst Typ.pp src pp arg
+    | Ap1 (Splat, _, byt) -> pf "%a^" pp byt
+    | Ap1 (Select idx, _, rcd) -> pf "%a[%i]" pp rcd idx
+    | Ap2 (Update idx, _, rcd, elt) ->
+        pf "[%a@ @[| %i → %a@]]" pp rcd idx pp elt
+    | Ap2 (Xor, Integer {bits= 1}, Integer {data}, x) when Z.is_true data ->
+        pf "¬%a" pp x
+    | Ap2 (Xor, Integer {bits= 1}, x, Integer {data}) when Z.is_true data ->
+        pf "¬%a" pp x
+    | Ap2 (op, _, x, y) -> pf "(%a@ %a %a)" pp x pp_op2 op pp y
+    | Ap3 (Conditional, _, cnd, thn, els) ->
+        pf "(%a@ ? %a@ : %a)" pp cnd pp thn pp els
+    | ApN (Record, _, elts) -> pf "{%a}" pp_record elts
+    [@@warning "-9"]
+
+  and pp_record fs elts =
+    match
+      String.init (IArray.length elts) ~f:(fun i ->
+          match IArray.get elts i with
+          | Integer {data; typ= Integer {byts= 1; _}} ->
+              Char.of_int_exn (Z.to_int data)
+          | _ -> raise_notrace (Invalid_argument "not a string") )
+    with
+    | s -> Format.fprintf fs "@[<h>%s@]" (String.escaped s)
+    | exception _ ->
+        Format.fprintf fs "@[<hv>%a@]" (IArray.pp ",@ " pp) elts
 end
 
 include T
@@ -86,88 +169,6 @@ end
 module Map = Map.Make (T)
 module Tbl = HashTable.Make (T)
 
-let demangle = ref (fun _ -> None)
-
-let pp_demangled ppf name =
-  match !demangle name with
-  | Some demangled when not (String.equal name demangled) ->
-      Format.fprintf ppf "“%s”" demangled
-  | _ -> ()
-
-let pp_op2 fs op =
-  let pf fmt = Format.fprintf fs fmt in
-  match op with
-  | Eq -> pf "="
-  | Dq -> pf "@<1>≠"
-  | Gt -> pf ">"
-  | Ge -> pf "@<1>≥"
-  | Lt -> pf "<"
-  | Le -> pf "@<1>≤"
-  | Ugt -> pf "u>"
-  | Uge -> pf "@<2>u≥"
-  | Ult -> pf "u<"
-  | Ule -> pf "@<2>u≤"
-  | Ord -> pf "ord"
-  | Uno -> pf "uno"
-  | Add -> pf "+"
-  | Sub -> pf "-"
-  | Mul -> pf "@<1>×"
-  | Div -> pf "/"
-  | Udiv -> pf "udiv"
-  | Rem -> pf "rem"
-  | Urem -> pf "urem"
-  | And -> pf "&&"
-  | Or -> pf "||"
-  | Xor -> pf "xor"
-  | Shl -> pf "shl"
-  | Lshr -> pf "lshr"
-  | Ashr -> pf "ashr"
-  | Update idx -> pf "[_|%i→_]" idx
-
-let rec pp fs exp =
-  let pf fmt =
-    Format.pp_open_box fs 2 ;
-    Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs fmt
-  in
-  match exp with
-  | Reg {name} -> pf "%%%s" name
-  | Global {name} -> pf "%@%s%a" name pp_demangled name
-  | Function {name} -> pf "&%s%a" name pp_demangled name
-  | Label {name} -> pf "%s" name
-  | Integer {data; typ= Pointer _} when Z.equal Z.zero data -> pf "null"
-  | Integer {data} -> Trace.pp_styled `Magenta "%a" fs Z.pp data
-  | Float {data} -> pf "%s" data
-  | Ap1 (Signed {bits}, dst, arg) ->
-      pf "((%a)(s%i)@ %a)" Typ.pp dst bits pp arg
-  | Ap1 (Unsigned {bits}, dst, arg) ->
-      pf "((%a)(u%i)@ %a)" Typ.pp dst bits pp arg
-  | Ap1 (Convert {src}, dst, arg) ->
-      pf "((%a)(%a)@ %a)" Typ.pp dst Typ.pp src pp arg
-  | Ap1 (Splat, _, byt) -> pf "%a^" pp byt
-  | Ap1 (Select idx, _, rcd) -> pf "%a[%i]" pp rcd idx
-  | Ap2 (Update idx, _, rcd, elt) ->
-      pf "[%a@ @[| %i → %a@]]" pp rcd idx pp elt
-  | Ap2 (Xor, Integer {bits= 1}, Integer {data}, x) when Z.is_true data ->
-      pf "¬%a" pp x
-  | Ap2 (Xor, Integer {bits= 1}, x, Integer {data}) when Z.is_true data ->
-      pf "¬%a" pp x
-  | Ap2 (op, _, x, y) -> pf "(%a@ %a %a)" pp x pp_op2 op pp y
-  | Ap3 (Conditional, _, cnd, thn, els) ->
-      pf "(%a@ ? %a@ : %a)" pp cnd pp thn pp els
-  | ApN (Record, _, elts) -> pf "{%a}" pp_record elts
-  [@@warning "-9"]
-
-and pp_record fs elts =
-  match
-    String.init (IArray.length elts) ~f:(fun i ->
-        match IArray.get elts i with
-        | Integer {data; typ= Integer {byts= 1; _}} ->
-            Char.of_int_exn (Z.to_int data)
-        | _ -> raise_notrace (Invalid_argument "not a string") )
-  with
-  | s -> Format.fprintf fs "@[<h>%s@]" (String.escaped s)
-  | exception _ -> Format.fprintf fs "@[<hv>%a@]" (IArray.pp ",@ " pp) elts
-
 (** Invariant *)
 
 let valid_idx idx elts = 0 <= idx && idx < IArray.length elts
@@ -281,18 +282,13 @@ and typ_of exp =
       typ
   [@@warning "-9"]
 
-let pp_exp = pp
-
 (** Registers are the expressions constructed by [Reg] *)
 module Reg = struct
   include T
 
-  let pp = pp
-
   module Set = struct
     include Set
-
-    let pp = Set.pp pp_exp
+    include Provide_pp (T)
   end
 
   let invariant x =
@@ -313,12 +309,9 @@ end
 module Global = struct
   include T
 
-  let pp = pp
-
   module Set = struct
     include Set
-
-    let pp = Set.pp pp_exp
+    include Provide_pp (T)
   end
 
   let invariant x =
@@ -339,7 +332,6 @@ end
 module Function = struct
   include T
 
-  let pp = pp
   let name = function Function x -> x.name | r -> violates invariant r
   let typ = function Function x -> x.typ | r -> violates invariant r
 

sledge/src/sh.ml

@@ -182,8 +182,7 @@ let pp_us ?vs fs us =
         [%Trace.fprintf fs "@<2>∀ @[%a@] .@ " Var.Set.pp us]
   | Some vs ->
       if not (Var.Set.equal vs us) then
-        [%Trace.fprintf
-          fs "@<2>∀ @[%a@] .@ " (Var.Set.pp_diff Var.pp) (vs, us)]
+        [%Trace.fprintf fs "@<2>∀ @[%a@] .@ " Var.Set.pp_diff (vs, us)]
 
 let rec pp_ ?var_strength ?vs ancestor_xs parent_ctx fs
     {us; xs; ctx; pure; heap; djns} =