pp.ml

(* Pretty-printing in OCaml: A Format Primer
   https://keleshev.com/pretty-printing-in-ocaml-a-format-primer *)

let printf = Format.printf
let fprintf = Format.fprintf
let sprintf = Format.asprintf

let pp_string ppf string = fprintf ppf "%S" string

let pp_print_list ~sep pp_item =
  Format.pp_print_list
    ~pp_sep:(fun ppf () -> fprintf ppf sep) pp_item

let example = [
  [];
  ["one"; "two"; "three"];
  [
    "one"; "two"; "three"; "four"; "five";
    "six"; "seven"; "eight"; "nine"; "ten";
  ];
]

let () = Format.set_margin 60

module No_boxes_or_break_hints = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "[%a]" 
      (pp_print_list ~sep:", " pp_item) list

  let () = 
    printf "No boxes or break hints:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Horizontal_xor_vertical_box = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<hv>[%a]@]" 
      (pp_print_list ~sep:",@;<1 1>" pp_item) list

  let () = 
    printf "Horizontal-xor-vertical 'hv' box:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Horizontal_xor_vertical_box_with_break_hints_near_brackets = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<hv>[@;<0 0>%a@;<0 0>]@]" 
      (pp_print_list ~sep:",@;<1 1>" pp_item) list

  let () = 
    printf "Horizontal-xor-vertical 'hv' box with break hints near brackets:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Horizontal_xor_vertical_box_with_break_hints_near_brackets_2_spaces_indent = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<hv>[@;<0 2>%a@;<0 0>]@]" 
      (pp_print_list ~sep:",@;<1 2>" pp_item) list

  let () = 
    printf "Horizontal-xor-vertical 'hv' box with break hints near brackets 2 spaces indent:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Horizontal_box = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<h>[@;<0 2>%a@;<0 0>]@]" 
      (pp_print_list ~sep:",@;<1 2>" pp_item) list

  let () = 
    printf "Horizontal 'h' box:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Vertical_box = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<v>[@;<0 2>%a@;<0 0>]@]" 
      (pp_print_list ~sep:",@;<1 2>" pp_item) list

  let () = 
    printf "Vertical 'v' box:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Compacting_hov_box = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<hov>[@;<0 1>%a@;<0 0>]@]" 
      (pp_print_list ~sep:",@;<1 1>" pp_item) list

  let () = 
    printf "Compacting 'hov' box:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end


module Compacting_b_box = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<b>[@;<0 1>%a@;<0 0>]@]" 
      (pp_print_list ~sep:",@;<1 1>" pp_item) list

  let () = 
    printf "Compacting 'b' box:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Comma_first = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<hv>[ %a@;<1 0>]@]" 
      (pp_print_list ~sep:"@;<0 0>, " pp_item) list

  let () = 
    printf "Comma first:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module Horizontal_xor_vertical_box_with_optional_trailing_comma = struct
  let pp_list pp_item ppf list = 
    fprintf ppf "@[<hv>[@;<0 2>%a%t]@]" 
      (pp_print_list ~sep:",@;<1 2>" pp_item) list
      (Format.pp_print_custom_break 
         ~fits:("", 0, "") ~breaks:(",", 0, ""))

  let () = 
    printf "Horizontal-xor-vertical 'hv' box with optional trailing comma:@.%a@.@." 
      (pp_list (pp_list pp_string)) example
end

module JSON = struct
  (* Invariants: utf8 strings, unique keys *)
  type t =
    | Null
    | Boolean of bool
    | Number of float
    | String of string
    | Array of t list
    | Object of (string * t) list

  (** Good-looking, round-trippable floats, inspired by:
      https://github.com/janestreet/base/blob/914648dae5/src/float.ml#L67-L175 *)
  let number_to_string n =
    let s = sprintf "%.15g" n in
    if Float.of_string s = n then 
      s 
    else
      sprintf "%.17g" n

  let pp_string_body ppf =
    String.iter (function
      | '"'    -> fprintf ppf {|\"|} (* {|"|} *)
      | '\\'   -> fprintf ppf {|\\|}
      | '\b'   -> fprintf ppf {|\b|}
      | '\x0C' -> fprintf ppf {|\f|}
      | '\n'   -> fprintf ppf {|\n|}
      | '\r'   -> fprintf ppf {|\r|}
      | '\t'   -> fprintf ppf {|\t|}
      | '\x00'..'\x1F' as non_print_char -> 
          fprintf ppf {|\u%.4X|} (Char.code non_print_char)
      | char   -> fprintf ppf {|%c|} char
    )

  let box pp ppf value = fprintf ppf "@[<hv>%a@]" pp value

  let rec pp ppf = function
    | Null      -> fprintf ppf "null"
    | Boolean b -> fprintf ppf "%b" b
    | Number n  -> fprintf ppf "%s" (number_to_string n)
    | String s  -> fprintf ppf {|"%a"|} pp_string_body s
    | Array a   -> fprintf ppf 
       "[@;<0 2>%a@;<0 0>]" 
       (pp_print_list ~sep:",@;<1 2>" (box pp)) a
    | Object o  -> fprintf ppf 
       "{@;<0 2>%a@;<0 0>}"
       (pp_print_list ~sep:",@;<1 2>" (box pp_pair)) o

  and pp_pair ppf (field, value) =
    fprintf ppf {|"%a": %a|} pp_string_body field pp value

  let to_string = sprintf "%a" (box pp)
end

let example =
  let open JSON in
  Object [
    "type", String "object";
    "properties", Object [
      "test", Object ["type", String "string"];
      "nexted", Object [
        "type", String "object";
        "properties", Object [
          "other", Object ["type", String "string"];
        ];
        "required", Array [];
        "additionalProperties", Boolean false;
      ];
    ];
    "required", Array [
      String "test";
      String "nested";
    ];
    "additionalProperties", Boolean false;
    "$id", String "https://example.com/my-schema.json";
    "$schema", String "http://json-schema.org/draft-07/schema#";
  ]

let () = 
  Format.printf "%s\n" (JSON.to_string example)

module Test = struct
  open JSON

  let test_null =
    assert (JSON.to_string Null = "null")
  
  let test_boolean =
    assert (JSON.to_string (Boolean true) = "true");
    assert (JSON.to_string (Boolean false) = "false")
  
  let test_number =
    assert (JSON.to_string (Number 1.0) = "1");
    assert (JSON.to_string (Number 3.14) = "3.14");
    assert (JSON.to_string (Number (1.0 /. 3.0)) = "0.33333333333333331")
  
  let test_string =
    assert (JSON.to_string (String "") = {|""|});
    assert (JSON.to_string (String "hi") = {|"hi"|});
    assert (JSON.to_string (String "\x00") = {|"\u0000"|});
    assert (JSON.to_string (String "\x1F") = {|"\u001F"|});
    assert (JSON.to_string (String "\u{1F}") = {|"\u001F"|});
    assert (JSON.to_string (String "\u{E6}\u{F8}\u{E5}") = {|"æøå"|});
    assert (JSON.to_string (String "æøå") = {|"æøå"|});
    assert (JSON.to_string (String "\n") = {|"\n"|})
  
  let test_array =
    let one, two = Number 1.0, Number 2.0 in
    assert (JSON.to_string (Array []) = "[]");
    assert (JSON.to_string (Array [one]) = "[1]");
    assert (JSON.to_string (Array [one; two]) = "[1, 2]")
  
  let test_object = 
    let one, two = Number 1.0, Number 2.0 in
    assert (JSON.to_string (Object []) = "{}");
    assert (JSON.to_string (Object [
      "this", one;
      "that", two;
    ]) = {|{"this": 1, "that": 2}|})
end