[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) =
+  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 pp_elt) lose ;
-    if not (is_empty gain) then Format.fprintf fs "++ %a" (pp pp_elt) gain
+      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_elt ppf {depth; edge} =
+        let pp ppf {depth; edge} =
           Format.fprintf ppf "%i: %a" depth Edge.pp edge
+      end
+
+      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,6 +9,7 @@ open Var_intf
 
 (** Variables, parameterized over their representation *)
 module Make (T : REPR) = struct
+  module T = struct
     include T
 
     type nonrec strength = t strength
@@ -22,10 +23,14 @@ module Make (T : REPR) = struct
           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 `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
+
+  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,28 +73,16 @@ module T = struct
     | Ap3 of op3 * Typ.t * t * t * t
     | ApN of opN * Typ.t * t iarray
   [@@deriving compare, equal, hash, sexp]
-end
-
-include T
 
-module Set = struct
-  include Set.Make (T)
-  include Provide_hash (T)
-  include Provide_of_sexp (T)
-end
+  let demangle = ref (fun _ -> None)
 
-module Map = Map.Make (T)
-module Tbl = HashTable.Make (T)
-
-let demangle = ref (fun _ -> None)
-
-let pp_demangled ppf name =
+  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 pp_op2 fs op =
     let pf fmt = Format.fprintf fs fmt in
     match op with
     | Eq -> pf "="
@@ -124,7 +112,7 @@ let pp_op2 fs op =
     | Ashr -> pf "ashr"
     | Update idx -> pf "[_|%i→_]" idx
 
-let rec pp fs exp =
+  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
@@ -157,7 +145,7 @@ let rec pp fs exp =
     | ApN (Record, _, elts) -> pf "{%a}" pp_record elts
     [@@warning "-9"]
 
-and pp_record fs elts =
+  and pp_record fs elts =
     match
       String.init (IArray.length elts) ~f:(fun i ->
           match IArray.get elts i with
@@ -166,7 +154,20 @@ and pp_record fs elts =
           | _ -> 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
+    | exception _ ->
+        Format.fprintf fs "@[<hv>%a@]" (IArray.pp ",@ " pp) elts
+end
+
+include T
+
+module Set = struct
+  include Set.Make (T)
+  include Provide_hash (T)
+  include Provide_of_sexp (T)
+end
+
+module Map = Map.Make (T)
+module Tbl = HashTable.Make (T)
 
 (** Invariant *)
 
@@ -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} =