Skip to content

Commit

Permalink
core: swap the cost ordering, rename functions, add printing variants
Browse files Browse the repository at this point in the history 
See CHANGES.md for details
  • Loading branch information
@sorawee
sorawee committed Feb 11, 2024
1 parent 4f3bb5a commit d0d0e89
Show file tree
Hide file tree
Showing 8 changed files with 394 additions and 278 deletions.
11 changes: 9 additions & 2 deletions CHANGES.md
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,14 @@
## 0.3 (2024-02-10)
## 0.3 (2024-02-11)

* Add `pretty_print_debug`
* Add the `two_columns` construct
* Rename `CostFacory.debug` to `CostFactory.string_of_cost`
* Reorganize pretty printing functions:
* Rename `Printer.Make.print` to `Printer.Make.pretty_format_info` (with slightly different signature)
* Rename `Printer.Make.pretty_print` to `Printer.Make.pretty_format`
* Add `Printer.Make.pretty_print`, `Printer.Make.pretty_print_info`, and `Printer.Make.pretty_format_debug`.
* Essentially, `Printer.Make.pretty_print(*)` is suitable for printing to a channel.
`Printer.Make.pretty_format(*)` is suitable for printing as a string.
The suffix `_info` indicates that it returns debugging information.

## 0.2 (2023-11-28)

Expand Down
26 changes: 14 additions & 12 deletions doc/index.mld
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ open P
]}

{[
# pretty_print (text "Hello" ^^ text " World!");;
# pretty_format (text "Hello" ^^ text " World!");;
- : string = "Hello World!"
]}

Expand Down Expand Up @@ -49,7 +49,7 @@ let print_doc (w : int) =
(space ^^ exit_d) <|> nest 4 (nl ^^ exit_d))) ^^
nl ^^ text "}"
in
pretty_print d
pretty_print print_string d
]}

There is a lot of code above, so let's unpack it.
Expand Down Expand Up @@ -113,7 +113,7 @@ This returns a string that we can then put on screen.
Let's now actually use the pretty printer with page width limit of 80.

{[
# print_doc 80 |> print_endline
# print_doc 80;;
while (true) {
f();
if (done()) exit();
Expand All @@ -126,7 +126,7 @@ compared to the second layout. By contrast, with the page width limit of 20,
the second layout is now chosen.

{[
# print_doc 20 |> print_endline
# print_doc 20;;
while (true) {
f();
if (done())
Expand Down Expand Up @@ -226,7 +226,7 @@ let print_sexp (s : sexp) (w : int) =
(x_d <+> space <+> vcat xs_d)) <+> (* the argument list style *)
rparen
in
pretty_print (pretty s)
pretty_print print_string (pretty s)
]}

The important point is that we reuse [x_d] and [xs_d] across [<|>].
Expand Down Expand Up @@ -278,7 +278,8 @@ exceeds the computation width limit of 5, since the indentation level exceeds 5

When all possible layout printing due to a document exceeds the computation width limit,
{!Pretty_expressive} will still output a layout, with no guarantee that the layout is optimal.
In such case, we say that the output layout is {i tainted}. The {{!Pretty_expressive.Util.info}[info]} record and the {{!Pretty_expressive.Printer.Make.print}[print]} function can be used to find if the output layout is tainted or not.
In such case, we say that the output layout is {i tainted}. The {{!Pretty_expressive.Util.info}[info]} record and
functions such as {{!Pretty_expressive.Printer.Make.pretty_print_info}[pretty_print_info]} can be used to find if the output layout is tainted or not.

{2:factory Cost Factory}

Expand Down Expand Up @@ -306,7 +307,7 @@ let example_sexp =
]}

{[
# print_sexp example_sexp 15 |> print_endline;;
# print_sexp example_sexp 15;;
(abc
def
(ghi jkl mno))
Expand Down Expand Up @@ -355,11 +356,12 @@ let my_cost_factory ~page_width ?computation_width () =
F.le c1 c2

let two_columns_overflow w = (F.two_columns_overflow w, 0)

let two_columns_bias w = (F.two_columns_bias w, 0)

let format_debug = F.format_debug
let string_of_cost (c, s) = Printf.sprintf "(%s %d)" (F.string_of_cost c) s

let debug (c, s) = Printf.sprintf "(%s %d)" (F.debug c) s
let debug_format = F.debug_format
end: Signature.CostFactory with type t = (int * int * int * int) * int)
]}

Expand Down Expand Up @@ -389,13 +391,13 @@ let revised_print_sexp (s : sexp) (w : int) =
(x_d <+> space <+> vcat xs_d)) <+> (* the argument list style *)
rparen
in
pretty_print (pretty s)
pretty_print print_string (pretty s)
]}

Now we can pretty print as we desired:

{[
# revised_print_sexp example_sexp 15 |> print_endline;;
# revised_print_sexp example_sexp 15;;
(abc def
(ghi jkl
mno))
Expand All @@ -408,7 +410,7 @@ With an even lower page width limit,
the vertical style is the only way to avoid overflow, so it is employed.

{[
# revised_print_sexp example_sexp 10 |> print_endline;;
# revised_print_sexp example_sexp 10;;
(abc
def
(ghi
Expand Down
116 changes: 69 additions & 47 deletions lib/printer.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,12 +5,12 @@ type 's treeof =
| One of 's
| Cons of 's treeof * 's treeof

let tree_flatten (t: 's treeof): 's list =
let rec loop (t: 's treeof) (acc: 's list) =
let render_tree (renderer : Signature.renderer) (t: 's treeof): unit =
let rec loop (t: 's treeof) =
match t with
| One v -> v :: acc
| Cons (x, y) -> loop x (loop y acc)
in loop t []
| One v -> renderer v
| Cons (x, y) -> loop x; loop y
in loop t

module Core (C : Signature.CostFactory) = struct
let global_id = ref 0
Expand All @@ -19,7 +19,7 @@ module Core (C : Signature.CostFactory) = struct
global_id := id + 1;
id

type measure = { last: int; cost: C.t; layout: string list -> string list }
type measure = { last: int; cost: C.t; layout: unit -> unit }

let (<==) (m1 : measure) (m2 : measure): bool =
m1.last <= m2.last && C.le m1.cost m2.cost
Expand Down Expand Up @@ -211,7 +211,9 @@ module Core (C : Signature.CostFactory) = struct
let (++) (m1 : measure) (m2 : measure): measure =
{ last = m2.last;
cost = C.combine m1.cost m2.cost;
layout = fun ss -> m1.layout (m2.layout ss) }
layout = fun () ->
m1.layout ();
m2.layout () }

let process_concat
(process_left : measure -> measure_set)
Expand Down Expand Up @@ -266,18 +268,23 @@ module Core (C : Signature.CostFactory) = struct
| MeasureSet (m :: _) -> m
| _ -> failwith "unreachable"

let print ?(init_c = 0) (d : doc): Util.info =
let pretty_print_info
?(init_c = 0)
(renderer : Signature.renderer)
(d : doc): cost Util.info =
let resolve self { dc; _ } (c : int) (i : int) : measure_set =
let core () =
match dc with
| Text (s, len_s) ->
MeasureSet [{ last = c + len_s;
cost = C.text c len_s;
layout = fun ss -> (tree_flatten s) @ ss }]
MeasureSet [{ last = c + len_s ;
cost = C.text c len_s ;
layout = fun () -> render_tree renderer s }]
| Newline _ ->
MeasureSet [{ last = i;
cost = C.newline i;
layout = fun ss -> "\n" :: String.make i ' ' :: ss }]
MeasureSet [{ last = i ;
cost = C.newline i ;
layout = fun () ->
renderer "\n";
renderer (String.make i ' ') }]
| Concat (d1, d2) ->
process_concat (fun (m1 : measure) -> self d2 m1.last i) (self d1 c i)
| Choice (d1, d2) ->
Expand Down Expand Up @@ -347,10 +354,8 @@ module Core (C : Signature.CostFactory) = struct
(* so the memoization tables should be cleared. *)
(* However, in OCaml, there is no need to do the same, *)
(* since a doc is tied to a cost factory. *)

{ out = String.concat "" (m.layout []);
is_tainted = is_tainted;
cost = C.debug m.cost }
m.layout ();
{ is_tainted ; cost = m.cost }
end

(* ----------------------------------------------------------------------0---- *)
Expand Down Expand Up @@ -410,13 +415,22 @@ module Make (C : Signature.CostFactory): (Signature.PrinterT with type cost = C.

let hcat = fold_doc (<->)

let pretty_print ?(init_c = 0) (d : doc): string =
(print ~init_c:init_c d).out
let pretty_format_info ?(init_c = 0) (d : doc): string * C.t Util.info =
let buf = Buffer.create 16 in
let info = pretty_print_info ~init_c:init_c (Buffer.add_string buf) d in
(Buffer.contents buf, info)

let pretty_print ?(init_c = 0) (renderer : Signature.renderer) (d : doc): unit =
let _ = pretty_print_info ~init_c:init_c renderer d in
()

let pretty_print_debug ?(init_c = 0) (d : doc): string =
let result = print ~init_c:init_c d in
C.format_debug result
let pretty_format ?(init_c = 0) (d : doc): string =
let (s, _) = pretty_format_info ~init_c:init_c d in s

let pretty_format_debug ?(init_c = 0) (d : doc): string =
let (content, ({ is_tainted ; cost } : C.t Util.info)) =
pretty_format_info ~init_c:init_c d in
C.debug_format content is_tainted (C.string_of_cost cost)
end


Expand All @@ -426,10 +440,33 @@ module MakeCompat (C : Signature.CostFactory): (Signature.PrinterCompatT with ty
let (<>) = (^^)
end

let make_debug_format page_width content is_tainted cost =
let lines = String.split_on_char '\n' content in
let zero_code = Char.code '0' in
let header = String.init
page_width
(fun i -> ((i + 1) mod 10 + zero_code) |> Char.chr) 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\n%s\n\nis_tainted: %b\ncost: %s"
header
content
is_tainted
cost

(* $MDX part-begin=default_cost_factory *)
let default_cost_factory ~page_width ?computation_width () =
(module struct
type t = int * 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
Expand All @@ -444,34 +481,19 @@ let default_cost_factory ~page_width ?computation_width () =
else
(0, 0, 0, 0)

let newline _ = (0, 1, 0, 0)
let newline _ = (0, 0, 1, 0)

let combine (o1, h1, ot1, bt1) (o2, h2, ot2, bt2) =
(o1 + o2, h1 + h2, ot1 + ot2, bt1 + bt2)
let combine (o1, ot1, h1, bt1) (o2, ot2, h2, bt2) =
(o1 + o2, ot1 + ot2, h1 + h2, bt1 + bt2)

let le c1 c2 = c1 <= c2

let two_columns_overflow w = (0, 0, w, 0)
let two_columns_bias w = (0, 0, 0, w)

let debug (o, h, ot, bt) = Printf.sprintf "(%d %d %d %d)" o h ot bt

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
let two_columns_overflow w = (0, w, 0, 0)

let two_columns_bias w = (0, 0, 0, w)

let string_of_cost (o, ot, h, bt) = Printf.sprintf "(%d %d %d %d)" o ot h bt

let debug_format = make_debug_format page_width
end: Signature.CostFactory with type t = int * int * int * int)
(* $MDX part-end *)
45 changes: 18 additions & 27 deletions lib/printer.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,10 @@ module MakeCompat(C : Signature.CostFactory): (Signature.PrinterCompatT with typ
that are compatible with the paper.
{b Using [open] on it will shadow built-in identifiers.} *)

val make_debug_format : int -> string -> bool -> string -> string
(** [make_debug_format limit content is_tainted cost] returns a debugging string
containing these parameters. *)

val default_cost_factory : page_width:int -> ?computation_width:int -> unit ->
(module Signature.CostFactory with type t = int * int * int * int)
(** The default cost factory, parameterized by the page width limit [page_width],
Expand All @@ -20,16 +24,18 @@ val default_cost_factory : page_width:int -> ?computation_width:int -> unit ->
{ul {- The first component is {i badness}, which is roughly speaking
the sum of squared overflows over the page width limit}
{- The second component is the height (number of newlines).}
{- The third component is sum of overflows over a column separator.}
{- The fourth component is bias toward choosing a leftmost column separator.} }
{- The second component is sum of overflows over a column separator.}
{- The third component is the height (number of newlines).}
{- The fourth component is bias penalty to encourage toward choosing
a leftmost column separator.} }
Internally, [default_cost_factory] is defined as:
{@ocaml file=printer.ml,part=default_cost_factory[
let default_cost_factory ~page_width ?computation_width () =
(module struct
type t = int * 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
Expand All @@ -44,34 +50,19 @@ let default_cost_factory ~page_width ?computation_width () =
else
(0, 0, 0, 0)
let newline _ = (0, 1, 0, 0)
let newline _ = (0, 0, 1, 0)
let combine (o1, h1, ot1, bt1) (o2, h2, ot2, bt2) =
(o1 + o2, h1 + h2, ot1 + ot2, bt1 + bt2)
let combine (o1, ot1, h1, bt1) (o2, ot2, h2, bt2) =
(o1 + o2, ot1 + ot2, h1 + h2, bt1 + bt2)
let le c1 c2 = c1 <= c2
let two_columns_overflow w = (0, 0, w, 0)
let two_columns_bias w = (0, 0, 0, w)
let debug (o, h, ot, bt) = Printf.sprintf "(%d %d %d %d)" o h ot bt
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
let two_columns_overflow w = (0, w, 0, 0)
let two_columns_bias w = (0, 0, 0, w)
let string_of_cost (o, ot, h, bt) = Printf.sprintf "(%d %d %d %d)" o ot h bt
let debug_format = make_debug_format page_width
end: Signature.CostFactory with type t = int * int * int * int)
]} *)
Loading

0 comments on commit d0d0e89

Please sign in to comment.