core: add pretty_print_debug / format_debug

CHANGES.md

@@ -1,3 +1,7 @@
+## 0.3 (2024-02-10)
+
+* Add `pretty_print_debug`
+
 ## 0.2 (2023-11-28)
 
 * Change `<>` to `^^` to avoid shadowing the not equal operator 

doc/index.mld

@@ -334,35 +334,31 @@ but with an extra component: the {i style cost}.
 {[
 let my_cost_factory ~page_width ?computation_width () =
   (module struct
-    type t = int * int * int
-    let limit = match computation_width with
-      | None -> (float_of_int page_width) *. 1.2 |> int_of_float
-      | Some computation_width -> computation_width
-
-    let text pos len =
-      let stop = pos + len in
-      if stop > page_width then
-        let maxwc = max page_width pos in
-        let a = maxwc - page_width in
-        let b = stop - maxwc in
-        (b * (2*a + b), 0, 0)
-      else
-        (0, 0, 0)
+    let cf = Printer.default_cost_factory ~page_width:page_width ?computation_width:computation_width ()
+    module F = (val cf)
+
+    type t = F.t * int
+
+    let limit = F.limit
 
-    let newline _ = (0, 1, 0)
+    let text pos len = (F.text pos len, 0)
 
-    let combine (o1, h1, s1) (o2, h2, s2) =
-      (o1 + o2, h1 + h2, s1 + s2)
+    let newline _ = (F.newline 0, 0)
+
+    let combine (c1, s1) (c2, s2) =
+      (F.combine c1 c2, s1 + s2)
+
+    let le (c1, s1) (c2, s2) =
+      if c1 = c2 then
+        s1 <= s2
+      else
+        F.le c1 c2
 
-    let le (o1, h1, s1) (o2, h2, s2) =
-      if o1 = o2 then
-        if h1 = h2 then s1 <= s2
-        else h1 < h2
-      else o1 < o2
+    let format_debug = F.format_debug
 
-    let debug (o, h, s) = Printf.sprintf "(%d %d %d)" o h s
+    let debug (c, s) = Printf.sprintf "(%s %d)" (F.debug c) s
 
-  end: Signature.CostFactory with type t = int * int * int)
+  end: Signature.CostFactory with type t = (int * int) * int)
 ]}
 
 We now construct a function to convert an S-expression into a document,
@@ -387,7 +383,7 @@ let revised_print_sexp (s : sexp) (w : int) =
       let xs_d = List.map pretty xs in
       lparen <+>
       (acat (x_d :: xs_d) <|> (* the horizontal style *)
-       (cost (0, 0, 1) (vcat (x_d :: xs_d))) <|> (* the vertical style -- penalized *)
+       (cost ((0, 0), 1) (vcat (x_d :: xs_d))) <|> (* the vertical style -- penalized *)
        (x_d <+> space <+> vcat xs_d)) <+> (* the argument list style *)
       rparen
   in

dune-project

@@ -15,6 +15,8 @@
 
 (documentation https://sorawee.github.io/pretty-expressive-ocaml/)
 
+(version 0.3)
+
 (using mdx 0.4)
 
 (package

lib/README.md

@@ -0,0 +1,13 @@
+The organization here is a little bit weird. This note explains why.
+
+The core of the pretty printer is `printer.ml`, and its companion signature file `printer.mli` depends on it.
+
+In both `printer.ml` and `printer.mli`, we need to specify module types (e.g., `PrinterT`). 
+However, if we define `PrinterT` in `printer.ml`, then we also need to define it again in `printer.mli`.
+
+Why don't want to duplicate the module types over and over again. 
+My solution is to define the module types in a new file `signature.mli`, 
+and then both `printer.ml` and `printer.mli` can refer to it.
+Note that `signature` is specified as `modules_without_implementation` under `dune`, and things work out.
+
+Stuff that are depended on by `signature.mli` and `printer.ml` are defined in `util.ml`.

lib/printer.ml

@@ -34,6 +34,7 @@ module Core (C : Signature.CostFactory) = struct
       memo_w: int;
       nl_cnt: int;
       table: ((int, measure_set) Hashtbl.t) option }
+  (* invariant: none of the docs contains Fail, unless it's a Fail itself. *)
   and doc_case =
     | Text of string treeof * int
     | Newline of string option
@@ -80,7 +81,7 @@ module Core (C : Signature.CostFactory) = struct
       let memo_w = calc_weight d in
       { dc = Cost (c, d);
         id = next_id ();
-        memo_w = memo_w;
+        memo_w;
         nl_cnt = d.nl_cnt;
         table = init_table memo_w }
 
@@ -96,7 +97,7 @@ module Core (C : Signature.CostFactory) = struct
       let memo_w = min (calc_weight d1) (calc_weight d2) in
       { dc = Concat (d1, d2);
         id = next_id ();
-        memo_w = memo_w;
+        memo_w;
         nl_cnt = d1.nl_cnt + d2.nl_cnt;
         table = init_table memo_w }
 
@@ -108,7 +109,7 @@ module Core (C : Signature.CostFactory) = struct
       let memo_w = calc_weight d in
       { dc = Nest (n, d);
         id = next_id ();
-        memo_w = memo_w;
+        memo_w;
         nl_cnt = d.nl_cnt;
         table = init_table memo_w }
 
@@ -120,7 +121,7 @@ module Core (C : Signature.CostFactory) = struct
       let memo_w = calc_weight d in
       { dc = Reset d;
         id = next_id ();
-        memo_w = memo_w;
+        memo_w;
         nl_cnt = d.nl_cnt;
         table = init_table memo_w }
 
@@ -143,7 +144,7 @@ module Core (C : Signature.CostFactory) = struct
       let memo_w = min (calc_weight d1) (calc_weight d2) in
       { dc = Choice (d1, d2);
         id = next_id ();
-        memo_w = memo_w;
+        memo_w;
         nl_cnt = max d1.nl_cnt d2.nl_cnt;
         table = init_table memo_w }
 
@@ -177,7 +178,7 @@ module Core (C : Signature.CostFactory) = struct
           match process_left m1 with
           | Tainted mt2 -> m1 ++ mt2 ()
           | MeasureSet (m2 :: _) -> m1 ++ m2
-          | _ -> failwith "impossible")
+          | _ -> failwith "unreachable")
     | MeasureSet ms1 ->
       let do_one (m1 : measure): measure_set =
         let rec loop ms2 result current_best =
@@ -193,9 +194,9 @@ module Core (C : Signature.CostFactory) = struct
         | _ -> failwith "unreachable" in
       let rec fold_right (ms: measure list): measure_set =
         match ms with
-        | [] -> failwith "unreachable"
         | [m] -> do_one m
         | m :: ms -> merge (do_one m) (fold_right ms)
+        | [] -> failwith "unreachable"
       in fold_right ms1
 
   let memoize f: doc -> int -> int -> measure_set =
@@ -214,6 +215,12 @@ module Core (C : Signature.CostFactory) = struct
       else f g d c i
     in g
 
+  let choose_one (ml : measure_set): measure =
+    match ml with
+    | Tainted mt -> mt ()
+    | MeasureSet (m :: _) -> m
+    | _ -> failwith "unreachable"
+
   let print ?(init_c = 0) (d : doc): Util.info =
     let resolve self { dc; _ } (c : int) (i : int) : measure_set =
       let core () =
@@ -245,17 +252,12 @@ module Core (C : Signature.CostFactory) = struct
         | Text (_, len) -> (c + len > C.limit) || (i > C.limit)
         | _ -> (c > C.limit) || (i > C.limit) in
       if exceeds then
-        Tainted (fun () ->
-            match core () with
-            | Tainted mt -> mt ()
-            | MeasureSet (m :: _) -> m
-            | _ -> failwith "impossible")
+        Tainted (fun () -> choose_one (core ()))
       else core () in
     let (m, is_tainted) = match memoize resolve d init_c 0 with
       | MeasureSet (m :: _) -> (m, false)
       | Tainted m -> (m (), true)
-      | _ -> failwith "impossible" in
-
+      | _ -> failwith "unreachable" in
     (* In Racket, a doc can be printed with many cost factories, *)
     (* so the memoization tables should be cleared. *)
     (* However, in OCaml, there is no need to do the same, *)
@@ -264,9 +266,6 @@ module Core (C : Signature.CostFactory) = struct
     { out = String.concat "" (m.layout []);
       is_tainted = is_tainted;
       cost = C.debug m.cost }
-
-  let pretty_print ?(init_c = 0) (d : doc): string =
-    (print ~init_c:init_c d).out
 end
 
 (* ----------------------------------------------------------------------0---- *)
@@ -332,6 +331,13 @@ module Make (C : Signature.CostFactory): (Signature.PrinterT with type cost = C.
   let hcat = fold_doc (<->)
   let vcat = fold_doc (<$>)
 
+  let pretty_print ?(init_c = 0) (d : doc): string =
+    (print ~init_c:init_c d).out
+
+  let pretty_print_debug ?(init_c = 0) (d : doc): string =
+    let result = print ~init_c:init_c d in
+    C.format_debug result
+
 end
 
 
@@ -369,5 +375,22 @@ let default_cost_factory ~page_width ?computation_width () =
 
     let debug (o, h) = Printf.sprintf "(%d %d)" o h
 
+    let format_debug (result : Util.info) =
+      let lines = String.split_on_char '\n' result.out in
+      let content =
+        List.map (fun l ->
+            if String.length l > page_width then
+              String.sub l 0 page_width ^
+              "│" ^
+              String.sub l page_width (String.length l - page_width)
+            else
+              l ^ String.make (page_width - String.length l) ' '  ^ "│") lines
+        |> String.concat "\n"
+      in
+      Printf.sprintf "%s\nis_tainted: %b\ncost: %s"
+        content
+        result.is_tainted
+        result.cost
+
   end: Signature.CostFactory with type t = int * int)
 (* $MDX part-end *)

lib/printer.mli

@@ -51,5 +51,22 @@ let default_cost_factory ~page_width ?computation_width () =
 
     let debug (o, h) = Printf.sprintf "(%d %d)" o h
 
+    let format_debug (result : Util.info) =
+      let lines = String.split_on_char '\n' result.out in
+      let content =
+        List.map (fun l ->
+            if String.length l > page_width then
+              String.sub l 0 page_width ^
+              "│" ^
+              String.sub l page_width (String.length l - page_width)
+            else
+              l ^ String.make (page_width - String.length l) ' '  ^ "│") lines
+        |> String.concat "\n"
+      in
+      Printf.sprintf "%s\nis_tainted: %b\ncost: %s"
+        content
+        result.is_tainted
+        result.cost
+
   end: Signature.CostFactory with type t = int * int)
 ]} *)

lib/signature.mli

@@ -41,6 +41,9 @@ sig
   val debug : t -> string
   (** [debug c] produces a string representation of a cost [c] *)
 
+  val format_debug : Util.info -> string
+  (** [format_debug s] produces a debugging string from the output of
+      the core printer. *)
 end
 
 module type PrinterT =
@@ -289,6 +292,13 @@ Languages: Racket
 - : unit = ()
       ]} *)
 
+  val pretty_print_debug : ?init_c:int -> doc -> string
+  (** [pretty_print_debug] is the same as
+      {{!Signature.PrinterT.pretty_print}[pretty_print]}, but it contains
+      extra debugging information, customizable via
+      {{!Signature.CostFactory.format_debug}[format_debug]} *)
+
+
   (** {2 Other derived combinators} *)
 
   val flatten : doc -> doc

pretty_expressive.opam

@@ -1,5 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
+version: "0.3"
 synopsis: "A pretty expressive printer"
 description:
   "A pretty printer implementation of 'A Pretty Expressive Printer' (OOPSLA'23), with an emphasis on expressiveness and optimality."