unikernel/duniverse/pp/src/dune

@@ -0,0 +1,2 @@
+(library
+ (public_name pp))

unikernel/duniverse/pp/src/pp.ml

@@ -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

unikernel/duniverse/pp/src/pp.mli

@@ -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