├── README.md ├── obj_pp.ml └── obj_pp.mli /README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | $ ocamlc -c obj_pp.mli obj_pp.ml 3 | # ocaml obj_pp.cmo 4 | # #install_printer Obj_pp.pp;; 5 | # Obj.repr [`first [|1.2; 3.4|]; `second (ref 1.2, ref "hola")];; 6 | - : Obj.t = 7 | ┌────┬────┬──────────┬──────────┐ 8 | │ 2│ 0│ ┬ [0]│ ┬ [1]│ 9 | └────┴────┴─────│────┴─────│────┘ 10 | │ │ 11 | │ │ ┌────┬────┬──────────┬──────────┐ 12 | │ └─┤ 2│ 0│ ┬ [0]│ 0│ 13 | │ └────┴────┴─────│────┴──────────┘ 14 | │ │ 15 | │ │ ┌────┬────┬──────────┬──────────┐ 16 | │ └─┤ 2│ 0│-465055884│ ┬ [1]│ 17 | │ └────┴────┴──────────┴─────│────┘ 18 | │ │ 19 | │ ┌────┬────┬──────────┬──────────┐ │ ┌────┬────┬──────────┬──────────┐ 20 | └─┤ 2│ 0│ 10319920│ ┬ [1]│ └─┤ 2│ 0│ ┬ [0]│ ┬ [1]│ 21 | └────┴────┴──────────┴─────│────┘ └────┴────┴─────│────┴─────│────┘ 22 | │ │ │ 23 | │ ┌────┬────┬──────────┬──────────┐ │ │ ┌────┬────┬──────────┐ 24 | └─┤ 2│ 254│ 1.2│ 3.4│ │ └─┤ 1│ 0│ ┬ [0]│ 25 | └────┴────┴──────────┴──────────┘ │ └────┴────┴─────│────┘ 26 | │ │ 27 | │ ┌────┬────┬──────────┐ │ ┌────┬────┬───────────────────┐ 28 | └─┤ 1│ 0│ ┬ [0]│ └─┤ 1│ 252│h o l a 00 00 00 03│ 29 | └────┴────┴─────│────┘ └────┴────┴───────────────────┘ 30 | │ 31 | │ ┌────┬────┬──────────┐ 32 | └─┤ 1│ 253│ 1.2│ 33 | └────┴────┴──────────┘ 34 | ``` 35 | -------------------------------------------------------------------------------- /obj_pp.ml: -------------------------------------------------------------------------------- 1 | module Ascii : sig 2 | type t 3 | 4 | val box: string list -> t 5 | val shift: int -> int -> t -> t 6 | val line: int -> t 7 | val zcat: t -> t -> t 8 | val vcat: t -> t -> t 9 | 10 | val overlaps: t -> t -> bool 11 | 12 | val size: t -> int * int 13 | val render: t -> string 14 | end = struct 15 | type t = 16 | | Box of string list 17 | | Shift of int * int * t 18 | | Line of int 19 | | Overlap of t * t 20 | 21 | let box l = Box l 22 | let line n = Line n 23 | let shift x y i = Shift (x, y, i) 24 | let zcat i1 i2 = Overlap (i1, i2) 25 | 26 | type rect = 27 | { 28 | x: int; 29 | y: int; 30 | width: int; 31 | height: int; 32 | } 33 | 34 | let rec bounding_rect i = 35 | let rec loop x y = function 36 | | Box l -> 37 | let width = 38 | let acc = ref 1 in 39 | List.iter (fun s -> acc := !acc + String.length s + 1) l; 40 | !acc 41 | in 42 | {x; y; width; height = 3} 43 | | Shift (dx, dy, i) -> 44 | loop (x + dx) (y + dy) i 45 | | Line height -> 46 | {x; y; width = 3; height} 47 | | Overlap (i1, i2) -> 48 | let r1 = loop x y i1 in 49 | let r2 = loop x y i2 in 50 | let x = min r1.x r2.x in 51 | let y = min r1.y r2.y in 52 | let width = max (r1.x + r1.width) (r2.x + r2.width) - x in 53 | let height = max (r1.y + r1.height) (r2.y + r2.height) - y in 54 | {x; y; width; height} 55 | in 56 | loop 0 0 i 57 | 58 | let shift_rect dx dy r = 59 | assert (0 <= dx && 0 <= dy); 60 | {r with x = r.x + dx; y = r.y + dy} 61 | 62 | let overlap_rect r1 r2 = 63 | let between min x max = min <= x && x <= max in 64 | (between r2.x r1.x (r2.x + r2.width) || 65 | between r1.x r2.x (r1.x + r1.width)) && 66 | (between r2.y r1.y (r2.y + r2.height) || 67 | between r1.y r2.y (r1.y + r1.height)) 68 | 69 | let rec overlaps i1 i2 = 70 | let rec loop (x1, y1, i1) (x2, y2, i2) = 71 | match i1, i2 with 72 | | Shift (dx1, dy1, i1), _ -> 73 | loop (x1 + dx1, y1 + dy1, i1) (x2, y2, i2) 74 | | _, Shift (dx2, dy2, i2) -> 75 | loop (x1, y1, i1) (x2 + dx2, y2 + dy2, i2) 76 | | Overlap (i1', i1''), _ -> 77 | loop (x1, y1, i1') (x2, y2, i2) || loop (x1, y1, i1'') (x2, y2, i2) 78 | | _, Overlap (i2', i2'') -> 79 | loop (x1, y1, i1) (x2, y2, i2') || loop (x1, y1, i1) (x2, y2, i2'') 80 | | Box _, Line _ | Line _, Box _ | Line _, Line _ | Box _, Box _ -> 81 | let r1 = bounding_rect i1 in 82 | let r2 = bounding_rect i2 in 83 | overlap_rect (shift_rect x1 y1 r1) (shift_rect x2 y2 r2) 84 | in 85 | loop (0, 0, i1) (0, 0, i2) 86 | 87 | let rec render a x y = function 88 | | Box l -> 89 | a.(y).(x) <- 0x250c; 90 | a.(y+1).(x) <- 0x2502; 91 | a.(y+2).(x) <- 0x2514; 92 | let x = ref x in 93 | List.iteri (fun idx s -> 94 | for i = 1 to String.length s do 95 | a.(y).(!x+i) <- 0x2500; 96 | a.(y+1).(!x+i) <- int_of_char s.[i-1]; 97 | a.(y+2).(!x+i) <- 0x2500 98 | done; 99 | x := !x + String.length s + 1; 100 | if idx < List.length l - 1 then begin 101 | a.(y).(!x) <- 0x252c; 102 | a.(y+2).(!x) <- 0x2534; 103 | end else begin 104 | a.(y).(!x) <- 0x2510; 105 | a.(y+2).(!x) <- 0x2518 106 | end; 107 | a.(y+1).(!x) <- 0x2502 108 | ) l 109 | | Shift (dx, dy, i) -> 110 | render a (x + dx) (y + dy) i 111 | | Line n -> 112 | a.(y).(x) <- 0x252c; 113 | for i = 1 to n - 2 do 114 | a.(y+i).(x) <- 0x2502 115 | done; 116 | a.(y+n-1).(x) <- 0x2514; 117 | a.(y+n-1).(x+1) <- 0x2500; 118 | a.(y+n-1).(x+2) <- 0x2524 119 | | Overlap (i1, i2) -> 120 | render a x y i1; 121 | render a x y i2 122 | 123 | let size i = 124 | let r = bounding_rect i in 125 | r.x + r.width, r.y + r.height 126 | 127 | let vcat i1 i2 = 128 | let _, height = size i1 in 129 | zcat i1 (shift 0 height i2) 130 | 131 | let render i = 132 | let width, height = size i in 133 | let a = Array.make_matrix height width 0 in 134 | render a 0 0 i; 135 | let buf = Buffer.create ((width+1) * height) in 136 | for y = 0 to height - 1 do 137 | for x = 0 to width - 1 do 138 | let n = a.(y).(x) in 139 | if n <> 0 then 140 | Buffer.add_utf_8_uchar buf (Uchar.of_int n) 141 | else 142 | Buffer.add_char buf ' ' 143 | done; 144 | Buffer.add_char buf '\n' 145 | done; 146 | Buffer.contents buf 147 | end 148 | 149 | let explode s = 150 | List.init (String.length s) (String.get s) 151 | 152 | let min_field_size = 10 153 | 154 | let fix s = 155 | if String.length s <= min_field_size then 156 | String.make (min_field_size - String.length s) ' ' ^ s 157 | else 158 | s 159 | 160 | let rec block x = 161 | let tag = Obj.tag x in 162 | let size = Obj.size x in 163 | let fields = 164 | if Obj.first_non_constant_constructor_tag <= tag && 165 | tag <= Obj.last_non_constant_constructor_tag 166 | then 167 | List.init size (fun i -> 168 | let x = Obj.field x i in 169 | if Obj.is_int x then 170 | Printf.sprintf "%d" (Obj.obj x) 171 | else 172 | "" 173 | ) 174 | else if tag = Obj.double_tag then 175 | [Printf.sprintf "%F" (Obj.double_field x 0)] 176 | else if tag = Obj.double_array_tag then 177 | List.init size (fun i -> 178 | let x = Obj.double_field x i in 179 | Printf.sprintf "%F" x 180 | ) 181 | else if tag = Obj.string_tag then 182 | let len = String.length (Obj.obj x) in 183 | let padding_len = (len + 8) / 8 * 8 - len in 184 | let padding = String.init padding_len (fun i -> if i = padding_len - 1 then char_of_int (padding_len - 1) else '\x00') in 185 | let chars = explode (Obj.obj x ^ padding) in 186 | [String.concat " " 187 | (List.map (fun c -> 188 | let n = int_of_char c in 189 | if 0x20 <= n && n <= 0x7e then 190 | Printf.sprintf "%c" c 191 | else 192 | Printf.sprintf "%02x" n 193 | ) chars)] 194 | else 195 | [Printf.sprintf ""] 196 | in 197 | let fields = List.map fix fields in 198 | let fields = Printf.sprintf "%4d" size :: Printf.sprintf "%4d" tag :: fields in 199 | let image = Ascii.box fields in 200 | let rec loop image sl i = 201 | if i < 0 then 202 | image 203 | else 204 | let s, sl = match sl with s :: sl -> s, sl | [] -> assert false in 205 | let pivot = 206 | List.fold_left (fun acc s -> acc + String.length s + 1) 1 sl + String.length s / 2 207 | in 208 | let x = Obj.field x i in 209 | if Obj.is_block x then 210 | let b = block x in 211 | let rec sub skip = 212 | let i = Ascii.shift (pivot + 2) (skip + 3) b in 213 | if Ascii.overlaps i image then 214 | sub (skip + 1) 215 | else 216 | Ascii.(zcat i (shift pivot 1 (line (4 + skip)))) 217 | in 218 | loop Ascii.(zcat image (sub 0)) sl (i - 1) 219 | else 220 | loop image sl (i - 1) 221 | in 222 | if Obj.first_non_constant_constructor_tag <= tag && 223 | tag <= Obj.last_non_constant_constructor_tag 224 | then 225 | loop image (List.rev fields) (size - 1) 226 | else 227 | image 228 | 229 | let pp ppf (x : Obj.t) = 230 | if Obj.is_int x then 231 | Format.fprintf ppf "0x%nx" Nativeint.(logor (shift_left (of_int (Obj.obj x)) 1) one) 232 | else 233 | try 234 | let s = Ascii.render (block x) in 235 | Format.fprintf ppf "@.%s" s 236 | with e -> 237 | Printf.eprintf "Error: %s\n" (Printexc.to_string e); 238 | Printexc.print_backtrace stderr; 239 | flush stderr 240 | -------------------------------------------------------------------------------- /obj_pp.mli: -------------------------------------------------------------------------------- 1 | val pp: Format.formatter -> Obj.t -> unit 2 | --------------------------------------------------------------------------------