This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions

View file

@ -0,0 +1,21 @@
The MIT License
Copyright (c) 2016 Jane Street Group, LLC <opensource@janestreet.com>
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

View file

@ -0,0 +1,3 @@
(library
(name pp)
(public_name dyn.pp))

View file

@ -0,0 +1,252 @@
module List = struct
include ListLabels
let map ~f t = rev (rev_map ~f t)
end
module String = StringLabels
module Ast = struct
type +'a t =
| Nop
| Seq of 'a t * 'a t
| Concat of 'a t * 'a t list
| Box of int * 'a t
| Vbox of int * 'a t
| Hbox of 'a t
| Hvbox of int * 'a t
| Hovbox of int * 'a t
| Verbatim of string
| Char of char
| Break of (string * int * string) * (string * int * string)
| Newline
| Text of string
| Tag of 'a * 'a t
end
include Ast
let of_ast = Fun.id
let to_ast = Fun.id
type ('a, 'tag) format_string = ('a, unit, string, 'tag t) format4
let rec map_tags t ~f =
match t with
| Nop -> Nop
| Seq (a, b) -> Seq (map_tags a ~f, map_tags b ~f)
| Concat (sep, l) -> Concat (map_tags sep ~f, List.map l ~f:(map_tags ~f))
| Box (indent, t) -> Box (indent, map_tags t ~f)
| Vbox (indent, t) -> Vbox (indent, map_tags t ~f)
| Hbox t -> Hbox (map_tags t ~f)
| Hvbox (indent, t) -> Hvbox (indent, map_tags t ~f)
| Hovbox (indent, t) -> Hovbox (indent, map_tags t ~f)
| (Verbatim _ | Char _ | Break _ | Newline | Text _) as t -> t
| Tag (tag, t) -> Tag (f tag, map_tags t ~f)
let rec filter_map_tags t ~f =
match t with
| Nop -> Nop
| Seq (a, b) -> Seq (filter_map_tags a ~f, filter_map_tags b ~f)
| Concat (sep, l) ->
Concat (filter_map_tags sep ~f, List.map l ~f:(filter_map_tags ~f))
| Box (indent, t) -> Box (indent, filter_map_tags t ~f)
| Vbox (indent, t) -> Vbox (indent, filter_map_tags t ~f)
| Hbox t -> Hbox (filter_map_tags t ~f)
| Hvbox (indent, t) -> Hvbox (indent, filter_map_tags t ~f)
| Hovbox (indent, t) -> Hovbox (indent, filter_map_tags t ~f)
| (Verbatim _ | Char _ | Break _ | Newline | Text _) as t -> t
| Tag (tag, t) -> (
let t = filter_map_tags t ~f in
match f tag with
| None -> t
| Some tag -> Tag (tag, t))
module Render = struct
open Format
let rec render ppf t ~tag_handler =
match t with
| Nop -> ()
| Seq (a, b) ->
render ppf ~tag_handler a;
render ppf ~tag_handler b
| Concat (_, []) -> ()
| Concat (sep, x :: l) ->
render ppf ~tag_handler x;
List.iter l ~f:(fun x ->
render ppf ~tag_handler sep;
render ppf ~tag_handler x)
| Box (indent, t) ->
pp_open_box ppf indent;
render ppf ~tag_handler t;
pp_close_box ppf ()
| Vbox (indent, t) ->
pp_open_vbox ppf indent;
render ppf ~tag_handler t;
pp_close_box ppf ()
| Hbox t ->
pp_open_hbox ppf ();
render ppf ~tag_handler t;
pp_close_box ppf ()
| Hvbox (indent, t) ->
pp_open_hvbox ppf indent;
render ppf ~tag_handler t;
pp_close_box ppf ()
| Hovbox (indent, t) ->
pp_open_hovbox ppf indent;
render ppf ~tag_handler t;
pp_close_box ppf ()
| Verbatim x -> pp_print_string ppf x
| Char x -> pp_print_char ppf x
| Break (fits, breaks) -> pp_print_custom_break ppf ~fits ~breaks
| Newline -> pp_force_newline ppf ()
| Text s -> pp_print_text ppf s
| Tag (tag, t) -> tag_handler ppf tag t
end
let to_fmt_with_tags = Render.render
let rec to_fmt ppf t =
Render.render ppf t ~tag_handler:(fun ppf _tag t -> to_fmt ppf t)
let nop = Nop
let seq a b = Seq (a, b)
let concat ?(sep = Nop) = function
| [] -> Nop
| [ x ] -> x
| l -> Concat (sep, l)
let concat_map ?(sep = Nop) l ~f =
match l with
| [] -> Nop
| [ x ] -> f x
| l -> Concat (sep, List.map l ~f)
let concat_mapi ?(sep = Nop) l ~f =
match l with
| [] -> Nop
| [ x ] -> f 0 x
| l -> Concat (sep, List.mapi l ~f)
let box ?(indent = 0) t = Box (indent, t)
let vbox ?(indent = 0) t = Vbox (indent, t)
let hbox t = Hbox t
let hvbox ?(indent = 0) t = Hvbox (indent, t)
let hovbox ?(indent = 0) t = Hovbox (indent, t)
let verbatim x = Verbatim x
let verbatimf fmt = Printf.ksprintf verbatim fmt
let char x = Char x
let custom_break ~fits ~breaks = Break (fits, breaks)
let break ~nspaces ~shift =
custom_break ~fits:("", nspaces, "") ~breaks:("", shift, "")
let space = break ~nspaces:1 ~shift:0
let cut = break ~nspaces:0 ~shift:0
let newline = Newline
let text s = Text s
let textf (fmt : ('a, 'tag) format_string) = Printf.ksprintf text fmt
let tag tag t = Tag (tag, t)
let paragraph s = hovbox (text s)
let paragraphf (fmt : ('a, 'tag) format_string) = Printf.ksprintf paragraph fmt
let enumerate l ~f =
vbox
(concat ~sep:cut
(List.map l ~f:(fun x -> box ~indent:2 (seq (verbatim "- ") (f x)))))
let chain l ~f =
vbox
(concat ~sep:cut
(List.mapi l ~f:(fun i x ->
box ~indent:3
(seq
(verbatim
(if i = 0 then
" "
else
"-> "))
(f x)))))
module O = struct
let ( ++ ) = seq
end
let compare =
let compare_both (type a b) (f : a -> a -> int) (g : b -> b -> int) (a, b)
(c, d) =
let r = f a c in
if r <> 0 then
r
else
g b d
in
(* Due to 4.08 lower bound, we need to define this here. *)
let rec compare_list a b ~cmp:f : int =
match (a, b) with
| [], [] -> 0
| [], _ :: _ -> -1
| _ :: _, [] -> 1
| x :: a, y :: b -> (
match (f x y : int) with
| 0 -> compare_list a b ~cmp:f
| ne -> ne)
in
fun compare_tag ->
let rec compare x y =
match (x, y) with
| Nop, Nop -> 0
| Nop, _ -> -1
| _, Nop -> 1
| Seq (a, b), Seq (c, d) -> compare_both compare compare (a, b) (c, d)
| Seq _, _ -> -1
| _, Seq _ -> 1
| Concat (a, b), Concat (c, d) ->
compare_both compare (compare_list ~cmp:compare) (a, b) (c, d)
| Concat _, _ -> -1
| _, Concat _ -> 1
| Box (a, b), Box (c, d) -> compare_both Int.compare compare (a, b) (c, d)
| Box _, _ -> -1
| _, Box _ -> 1
| Vbox (a, b), Vbox (c, d) ->
compare_both Int.compare compare (a, b) (c, d)
| Vbox _, _ -> -1
| _, Vbox _ -> 1
| Hbox a, Hbox b -> compare a b
| Hbox _, _ -> -1
| _, Hbox _ -> 1
| Hvbox (a, b), Hvbox (c, d) ->
compare_both Int.compare compare (a, b) (c, d)
| Hvbox _, _ -> -1
| _, Hvbox _ -> 1
| Hovbox (a, b), Hovbox (c, d) ->
compare_both Int.compare compare (a, b) (c, d)
| Hovbox _, _ -> -1
| _, Hovbox _ -> 1
| Verbatim a, Verbatim b -> String.compare a b
| Verbatim _, _ -> -1
| _, Verbatim _ -> 1
| Char a, Char b -> Char.compare a b
| Char _, _ -> -1
| _, Char _ -> 1
| Break (a, b), Break (c, d) ->
let compare (x, y, z) (a, b, c) =
compare_both String.compare
(compare_both Int.compare String.compare)
(x, (y, z))
(a, (b, c))
in
compare_both compare compare (a, b) (c, d)
| Break _, _ -> -1
| _, Break _ -> 1
| Newline, Newline -> 0
| Newline, _ -> -1
| _, Newline -> 1
| Text a, Text b -> String.compare a b
| Text _, _ -> -1
| _, Text _ -> 1
| Tag (a, b), Tag (c, d) -> compare_both compare_tag compare (a, b) (c, d)
in
compare

View file

@ -0,0 +1,234 @@
(** Pretty-printing. *)
(** ['tag t] represents a document that is not yet rendered. The argument ['tag]
is the type of tags in the document. For instance tags might be used for
styles.
If you want to serialise and deserialise this datastructure, you can use the
[Ast.t] type together with the [of_ast] and [to_ast] functions. *)
type +'tag t
(** {1 Basic combinators} *)
(** A pretty printer that prints nothing *)
val nop : 'tag t
(** [seq x y] prints [x] and then [y] *)
val seq : 'tag t -> 'tag t -> 'tag t
(** [concat ?sep l] prints elements in [l] separated by [sep]. [sep] defaults to
[nop]. *)
val concat : ?sep:'tag t -> 'tag t list -> 'tag t
(** Convenience function for [List.map] followed by [concat]. *)
val concat_map : ?sep:'tag t -> 'a list -> f:('a -> 'tag t) -> 'tag t
(** Convenience function for [List.mapi] followed by [concat]. *)
val concat_mapi : ?sep:'tag t -> 'a list -> f:(int -> 'a -> 'tag t) -> 'tag t
(** An indivisible block of text. *)
val verbatim : string -> 'tag t
(** Same as [verbatim] but take a format string as argument. *)
val verbatimf : ('a, unit, string, 'tag t) format4 -> 'a
(** A single character. *)
val char : char -> 'tag t
(** Print a bunch of text. The line may be broken at any spaces in the text. *)
val text : string -> 'tag t
(** Same as [text] but take a format string as argument. *)
val textf : ('a, unit, string, 'tag t) format4 -> 'a
(** {1 Break hints} *)
(** [space] instructs the pretty-printing algorithm that the line may be broken
at this point. If the algorithm decides not to break the line, a single
space will be printed instead.
So for instance [verbatim "x" ++ space ++ verbatim "y"] might produce "x y"
or "x\n<indentation>y". *)
val space : 'tag t
(** [cut] instructs the pretty-printing algorithm that the line may be broken at
this point. If the algorithm decides not to break the line, nothing is
printed instead.
So for instance [verbatim "x" ++ space ++ verbatim "y"] might produce "xy"
or "x\n<indentation>y". *)
val cut : 'tag t
(** [break] is a generalisation of [space] and [cut]. It also instructs the
pretty-printing algorithm that the line may be broken at this point. If it
ends up being broken, [shift] will be added to the indentation level,
otherwise [nspaces] spaces will be printed. [shift] can be negative, in
which case the indentation will be reduced. *)
val break : nspaces:int -> shift:int -> 'tag t
(** [custom_break ~fits:(a, b, c) ~breaks:(x, y, z)] is a generalisation of
[break]. It also instructs the pretty-printing algorithm that the line may
be broken at this point. If it ends up being broken, [x] is printed, the
line breaks, [y] will be added to the indentation level and [z] is printed,
otherwise [a] will be printed, [b] spaces are printed and then [c] is
printed. The indentation [y] can be negative, in which case the indentation
will be reduced. *)
val custom_break :
fits:string * int * string -> breaks:string * int * string -> 'tag t
(** Force a newline to be printed. Usage is discourage since it breaks printing
with boxes. If you need to add breaks to your text, put your items into
[box]es and [concat] with a separating [space] afterwhich wrapping it in a
[vbox]. *)
val newline : 'tag t
(** {1 Boxes} *)
(** Boxes are the basic components to control the layout of the text. Break
hints such as [space] and [cut] may cause the line to be broken, depending
on the splitting rules. Whenever a line is split, the rest of the material
printed in the box is indented with [indent].
You can think of a box with indentation as something with this shape:
{v
######################### <- first line
<indent>#################
<indent>#################
<indent>#################
<indent>#################
v}
And the top left corner of this shape is anchored where the box was
declared. So for instance, the following document:
{[
Pp.verbatim "....." ++ Pp.box ~indent:2 (Pp.text "some long ... text")
]}
would produce:
{v
.....some long ...
text
v} *)
(** Try to put as much as possible on each line. Additionally, a break hint
always break the line if the breaking would reduce the indentation level
inside the box ([break] with negative [shift] value). *)
val box : ?indent:int -> 'tag t -> 'tag t
(** Always break the line when encountering a break hint. *)
val vbox : ?indent:int -> 'tag t -> 'tag t
(** Print everything on one line, no matter what *)
val hbox : 'tag t -> 'tag t
(** If possible, print everything on one line. Otherwise, behave as a [vbox] *)
val hvbox : ?indent:int -> 'tag t -> 'tag t
(** Try to put as much as possible on each line. Basically the same as [box] but
without the rule about breaks with negative [shift] value. *)
val hovbox : ?indent:int -> 'tag t -> 'tag t
(** {1 Tags} *)
(** Tags are arbitrary pieces of information attached to a document. They can be
used to add styles to pretty-printed text, for instance to print to the
terminal with colors. *)
(** [tag x t] Tag the material printed by [t] with [x] *)
val tag : 'tag -> 'tag t -> 'tag t
(** Convert tags in a documents *)
val map_tags : 'from_tag t -> f:('from_tag -> 'to_tag) -> 'to_tag t
(** Convert tags in a documents, possibly removing some tags. *)
val filter_map_tags :
'from_tag t -> f:('from_tag -> 'to_tag option) -> 'to_tag t
(** {1 Convenience functions} *)
(** [paragraph s] is [hovbox (text s)]. This is useful to preserve the structure
of a paragraph of text without worrying about it being broken by a [vbox]. *)
val paragraph : string -> 'tag t
(** [paragraphf s] is [textf s] followed by a [hovbox]. The [textf] version of
[paragraph]. *)
val paragraphf : ('a, unit, string, 'tag t) format4 -> 'a
(** [enumerate l ~f] produces an enumeration of the form:
{v
- item1
- item2
- item3
...
v} *)
val enumerate : 'a list -> f:('a -> 'tag t) -> 'tag t
(** [chain l ~f] is used to print a succession of items that follow each other.
It produces an output of this form:
{v
item1
-> item2
-> item3
...
v} *)
val chain : 'a list -> f:('a -> 'tag t) -> 'tag t
(** {1 Operators} *)
module O : sig
(** Infix operators for [Pp.t] *)
(** Same as [seq] *)
val ( ++ ) : 'tag t -> 'tag t -> 'tag t
end
(** {1 Rendering} *)
(** Render a document to a classic formatter *)
val to_fmt : Format.formatter -> 'tag t -> unit
val to_fmt_with_tags :
Format.formatter
-> 'tag t
-> tag_handler:(Format.formatter -> 'tag -> 'tag t -> unit)
-> unit
(** {1 Ast} *)
module Ast : sig
(** Stable representation of [Pp.t] useful for serialization *)
(** Stable abstract syntax tree for [Pp.t] that can be used for serialization
and deserialization. *)
type +'tag t =
| Nop
| Seq of 'tag t * 'tag t
| Concat of 'tag t * 'tag t list
| Box of int * 'tag t
| Vbox of int * 'tag t
| Hbox of 'tag t
| Hvbox of int * 'tag t
| Hovbox of int * 'tag t
| Verbatim of string
| Char of char
| Break of (string * int * string) * (string * int * string)
| Newline
| Text of string
| Tag of 'tag * 'tag t
end
(** [of_ast t] converts an [Ast.t] to a [Pp.t]. *)
val of_ast : 'tag Ast.t -> 'tag t
(** [to_ast t] converts a [Pp.t] to an [Ast.t]. *)
val to_ast : 'tag t -> 'tag Ast.t
(** {1 Comparison} *)
(** [compare cmp x y] compares [x] and [y] using [cmp] to compare tags. *)
val compare : ('tag -> 'tag -> int) -> 'tag t -> 'tag t -> int