src/pretty.ml

   1 open Format
   2
   3 exception InvalidUtf8Codepoint of int
   4
   5 let subscripts = "₀₁₂₃₄₅₆₇₈₉"
   6 let superscripts = "⁰¹²³⁴⁵⁶⁷⁸⁹"
   7
   8 let char_length c =
   9   let code = Char.code c in
  10     if code <= 0x7f then 1
  11     else if 0xc2 <= code && code <= 0xdf then 2
  12     else if 0xe0 <= code && code <= 0xef then 3
  13     else if 0xf0 <= code && code <= 0xf4 then 4
  14     else raise (InvalidUtf8Codepoint code)
  15
  16
  17 let next_char s i len =
  18   let n = i + char_length s.[i] in
  19     if n >= len then -1 else n
  20
  21 let str_len s =
  22   let len = String.length s in
  23   let rec loop i acc =
  24     if i == -1 then acc
  25     else loop (next_char s i len) (acc+1)
  26   in
  27     loop 0 0
  28
  29 let length = str_len
  30
  31 let get_char s i =
  32   let len = String.length s in
  33   let rec loop j count =
  34     if count == i then String.sub s j (char_length s.[j])
  35     else loop (next_char s j len) (count+1)
  36   in
  37     loop 0 0
  38
  39
  40 let format_number digits i =
  41   let s = string_of_int i in
  42   let len = String.length s in
  43   let buf = Buffer.create (len*4) in
  44     for i = 0 to len - 1 do
  45       let d = Char.code s.[i] - Char.code '0' in
  46         Buffer.add_string buf (get_char digits d)
  47     done;
  48     Buffer.contents buf
  49
  50 let rev_explode s =
  51   let len = str_len s in
  52   let rec loop i acc =
  53       if i >= len then acc
  54       else
  55         loop (i+1) ((get_char s i) :: acc)
  56   in
  57       loop 0 []
  58
  59
  60 let explode s = List.rev (rev_explode s)
  61
  62 let combine_all comp s =
  63   let l = rev_explode s in
  64   String.concat "" (List.fold_left (fun acc e -> comp::e::acc) [] l)
  65
  66
  67 let subscript = format_number subscripts
  68 let superscript = format_number superscripts
  69 let down_arrow = "↓"
  70 let up_arrow = "↑"
  71 let right_arrow = "→"
  72 let left_arrow =  "←"
  73 let epsilon = "ϵ"
  74 let cap = "∩"
  75 let cup = "∪"
  76 let lnot = "¬"
  77 let wedge = "∧"
  78 let vee = "∨"
  79 let top = "⊤"
  80 let bottom = "⊥"
  81 let dummy = "☠"
  82 let double_right_arrow = "⇒"
  83 let combining_overbar = "\204\133"
  84 let combining_underbar = "\204\178"
  85 let combining_stroke = "\204\182"
  86 let combining_vertical_line = "\226\131\146"
  87
  88
  89 let overline s = combine_all combining_overbar s
  90 let underline s = combine_all combining_underbar s
  91 let strike s = combine_all combining_stroke s
  92
  93 let mk_repeater c =
  94   let mk_str i = String.make i c in
  95   let _table = Array.init 16 mk_str in
  96      fun i -> try
  97       if i < 16 then _table.(i) else mk_str i
  98     with e -> print_int i; print_newline(); raise e
  99 let padding = mk_repeater ' '
 100 let line = mk_repeater '_'
 101
 102
 103
 104
 105 let ppf f fmt s =
 106   pp_print_string fmt (f s)
 107
 108 let pp_overline = ppf overline
 109 let pp_underline = ppf underline
 110 let pp_strike = ppf strike
 111 let pp_subscript = ppf subscript
 112 let pp_superscript = ppf superscript
 113 let dummy_printer fmt () = ()
 114
 115 let pp_print_list ?(sep=dummy_printer) printer fmt l =
 116   match l with
 117     [] -> ()
 118   | [ e ] -> printer fmt e
 119   | e :: es -> printer fmt e; List.iter
 120     (fun x ->
 121       sep fmt ();
 122       fprintf fmt "%a" printer x) es
 123
 124 let pp_print_array ?(sep=dummy_printer) printer fmt a =
 125   pp_print_list ~sep:sep printer fmt (Array.to_list a)
 126
 127 let print_list ?(sep=" ") printer fmt l =
 128   let sep_printer fmt () =
 129     pp_print_string fmt sep
 130   in
 131   pp_print_list ~sep:sep_printer printer fmt l
 132
 133 let print_array ?(sep=" ") printer fmt a =
 134   print_list ~sep:sep printer fmt (Array.to_list a)
 135
 136