Declarative JSON data manipulation for OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2024 The jsont programmers. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(* These three things should really belong to String. *)
7
8let string_subrange ?(first = 0) ?last s =
9 let max = String.length s - 1 in
10 let last =
11 match last with None -> max | Some l when l > max -> max | Some l -> l
12 in
13 let first = if first < 0 then 0 else first in
14 if first > last then "" else String.sub s first (last - first + 1)
15
16let edit_distance s0 s1 =
17 let min_by f a b = if f a <= f b then a else b in
18 let max_by f a b = if f a <= f b then b else a in
19 let minimum a b c = min a (min b c) in
20 let s0 = min_by String.length s0 s1 (* row *)
21 and s1 = max_by String.length s0 s1 in
22 (* column *)
23 let m = String.length s0 and n = String.length s1 in
24 let rec rows row0 row i =
25 if i > n then row0.(m)
26 else begin
27 row.(0) <- i;
28 for j = 1 to m do
29 if s0.[j - 1] = s1.[i - 1] then row.(j) <- row0.(j - 1)
30 else
31 row.(j) <- minimum (row0.(j - 1) + 1) (row0.(j) + 1) (row.(j - 1) + 1)
32 done;
33 rows row row0 (i + 1)
34 end
35 in
36 rows (Array.init (m + 1) (fun x -> x)) (Array.make (m + 1) 0) 1
37
38let suggest ?(dist = 2) candidates s =
39 let add (min, acc) name =
40 let d = edit_distance s name in
41 if d = min then (min, name :: acc)
42 else if d < min then (d, [ name ])
43 else (min, acc)
44 in
45 let d, suggs = List.fold_left add (max_int, []) candidates in
46 if d <= dist (* suggest only if not too far *) then List.rev suggs else []
47
48(* Hex converters *)
49
50let lower_hex_digit n =
51 let n = n land 0xF in
52 Char.unsafe_chr (if n < 10 then 0x30 + n else 0x57 + n)
53
54let binary_string_to_hex s =
55 let rec loop max s i h k =
56 if i > max then Bytes.unsafe_to_string h
57 else
58 let byte = Char.code s.[i] in
59 Bytes.set h k (lower_hex_digit (byte lsr 4));
60 Bytes.set h (k + 1) (lower_hex_digit byte);
61 loop max s (i + 1) h (k + 2)
62 in
63 let len = String.length s in
64 let h = Bytes.create (2 * len) in
65 loop (len - 1) s 0 h 0
66
67exception Illegal_hex of int
68
69let err_illegal_hex h i =
70 if i = String.length h then Error "Missing final hexadecimal digit"
71 else
72 let c = String.get_uint8 h i in
73 Error (Fmt.str "%d: byte x%x not an ASCII hexadecimal digit" i c)
74
75let binary_string_of_hex h =
76 let hex_value s i =
77 match s.[i] with
78 | '0' .. '9' as c -> Char.code c - 0x30
79 | 'A' .. 'F' as c -> 10 + (Char.code c - 0x41)
80 | 'a' .. 'f' as c -> 10 + (Char.code c - 0x61)
81 | _ -> raise_notrace (Illegal_hex i)
82 in
83 try
84 match String.length h with
85 | len when len mod 2 <> 0 -> raise (Illegal_hex len)
86 | len ->
87 let rec loop max s i h k =
88 if i > max then Ok (Bytes.unsafe_to_string s)
89 else
90 let hi = hex_value h k and lo = hex_value h (k + 1) in
91 Bytes.set s i (Char.chr @@ ((hi lsl 4) lor lo));
92 loop max s (i + 1) h (k + 2)
93 in
94 let s_len = len / 2 in
95 let s = Bytes.create s_len in
96 loop (s_len - 1) s 0 h 0
97 with Illegal_hex i -> err_illegal_hex h i
98
99(* Resizable arrays *)
100
101module Rarray = struct
102 type 'a t = {
103 mutable els : 'a array;
104 mutable max : int; (* index of last element of [els]. *)
105 }
106
107 let get a i = a.els.(i)
108 let empty () = { els = [||]; max = -1 }
109
110 let grow a v =
111 let len = a.max + 1 in
112 let els' = Array.make (2 * if len = 0 then 1 else len) v in
113 Array.blit a.els 0 els' 0 len;
114 a.els <- els'
115
116 let length a = a.max + 1
117
118 let add_last v a =
119 let max = a.max + 1 in
120 if max = Array.length a.els then grow a v;
121 a.max <- max;
122 a.els.(max) <- v;
123 a
124
125 let to_array a =
126 if a.max + 1 = Array.length a.els then a.els
127 else
128 let v = Array.make (a.max + 1) a.els.(0) in
129 Array.blit a.els 0 v 0 (a.max + 1);
130 v
131end
132
133(* Resizable bigarrays *)
134
135module Rbigarray1 = struct
136 type ('a, 'b, 'c) t = {
137 mutable els : ('a, 'b, 'c) Bigarray.Array1.t;
138 mutable max : int; (* index of the last element of [els]. *)
139 }
140
141 let get a i = Bigarray.Array1.get a.els i
142
143 let empty kind layout =
144 { els = Bigarray.Array1.create kind layout 0; max = -1 }
145
146 let grow a v =
147 let len = a.max + 1 in
148 let len = if len = 0 then 1 else len in
149 let init i = Bigarray.Array1.(if i <= a.max then get a.els i else v) in
150 let k, l = Bigarray.Array1.(kind a.els, layout a.els) in
151 let els' = Bigarray.Array1.init k l (2 * len) init in
152 a.els <- els'
153
154 let length a = a.max + 1
155
156 let add_last v a =
157 let max = a.max + 1 in
158 if max = Bigarray.Array1.dim a.els then grow a v;
159 a.max <- max;
160 Bigarray.Array1.set a.els max v;
161 a
162
163 let to_bigarray a =
164 if a.max + 1 = Bigarray.Array1.dim a.els then a.els
165 else
166 let init i = Bigarray.Array1.get a.els i in
167 let k, l = Bigarray.Array1.(kind a.els, layout a.els) in
168 Bigarray.Array1.init k l (a.max + 1) init
169end
170
171(* Mini fmt *)
172
173module Fmt = struct
174 type 'a t = 'a Fmt.t
175
176 let pf = Fmt.pf
177 let str = Fmt.str
178 let kstr = Fmt.kstr
179 let nop = Fmt.nop
180 let sp = Fmt.sp
181 let char = Fmt.char
182 let string = Fmt.string
183 let list = Fmt.list
184 let comma ppf () = Fmt.pf ppf ",@ "
185
186 let substring first len ppf s =
187 if first = 0 && len = String.length s then Fmt.string ppf s
188 else
189 for i = first to first + len - 1 do
190 Fmt.char ppf s.[i]
191 done
192
193 let lines ppf s = Fmt.(list ~sep:cut string) ppf (String.split_on_char '\n' s)
194
195 (* ANSI styling
196
197 Note this is the scheme we have in More.Fmt but obviously
198 we can't depend on it. For now we decided not to surface it
199 at the library level. Ideally something should be provided
200 upstream. *)
201
202 type styler = Ansi | Plain
203
204 let styler' =
205 Atomic.make
206 @@
207 match Sys.getenv_opt "NO_COLOR" with
208 | Some s when s <> "" -> Plain
209 | _ -> (
210 match Sys.getenv_opt "TERM" with
211 | Some "dumb" -> Plain
212 | None when Sys.backend_type <> Other "js_of_ocaml" -> Plain
213 | _ -> Ansi)
214
215 let set_styler styler = Atomic.set styler' styler
216 let ansi_reset = "\x1B[0m"
217
218 let bold ppf s =
219 if Atomic.get styler' = Plain then string ppf s
220 else pf ppf "@<0>%s%s@<0>%s" "\x1B[1m" s ansi_reset
221
222 let bold_red ppf s =
223 if Atomic.get styler' = Plain then string ppf s
224 else pf ppf "@<0>%s%s@<0>%s" "\x1B[31;1m" s ansi_reset
225
226 let code = bold
227
228 let puterr ppf () =
229 bold_red ppf "Error";
230 char ppf ':'
231
232 let disable_ansi_styler () = set_styler Plain
233
234 (* HCI fragments *)
235
236 let op_enum op ?(empty = nop) pp_v ppf = function
237 | [] -> empty ppf ()
238 | [ v ] -> pp_v ppf v
239 | _ as vs ->
240 let rec loop ppf = function
241 | [ v0; v1 ] -> pf ppf "%a@ %s@ %a" pp_v v0 op pp_v v1
242 | v :: vs ->
243 pf ppf "%a,@ " pp_v v;
244 loop ppf vs
245 | [] -> assert false
246 in
247 loop ppf vs
248
249 let or_enum ?empty pp_v ppf vs = op_enum "or" ?empty pp_v ppf vs
250
251 let should_it_be pp_v ppf = function
252 | [] -> ()
253 | vs -> pf ppf "Should it be %a ?" (or_enum pp_v) vs
254
255 let must_be pp_v ppf = function
256 | [] -> ()
257 | vs -> pf ppf "Must be %a." (or_enum pp_v) vs
258
259 let unexpected ~kind pp_v ppf v = pf ppf "Unexpected %a: %a." kind () pp_v v
260
261 let unexpected' ~kind pp_v ~hint ppf (v, hints) =
262 match hints with
263 | [] -> unexpected ~kind pp_v ppf v
264 | hints ->
265 unexpected ~kind pp_v ppf v;
266 sp ppf ();
267 (hint pp_v) ppf hints
268
269 let out_of_dom ?pp_kind () ppf (s, ss) =
270 let kind =
271 match pp_kind with
272 | None -> fun ppf () -> string ppf "value"
273 | Some pp_kind -> pp_kind
274 in
275 let hint, ss =
276 match suggest ss s with [] -> (must_be, ss) | ss -> (should_it_be, ss)
277 in
278 pf ppf "@[%a@]" (unexpected' ~kind code ~hint) (s, ss)
279
280 let similar_mems ppf (exp, fnd) =
281 match suggest fnd exp with
282 | [] -> ()
283 | ms ->
284 pf ppf "@;@[Similar members in object: %a@]" (list ~sep:comma code) ms
285
286 let should_it_be_mem ppf (exp, fnd) =
287 match suggest fnd exp with
288 | [] -> ()
289 | ms -> pf ppf "@;@[%a@]" (should_it_be code) ms
290
291 (* JSON formatting *)
292
293 type json_number_format = (float -> unit, Format.formatter, unit) format
294
295 let json_default_number_format : json_number_format = format_of_string "%.17g"
296 let json_null ppf () = string ppf "null"
297 let json_bool ppf b = string ppf (if b then "true" else "false")
298
299 let json_number' fmt ppf f =
300 (* cf. ECMAScript's JSON.stringify *)
301 if Float.is_finite f then pf ppf fmt f else json_null ppf ()
302
303 let json_number ppf f = json_number' json_default_number_format ppf f
304
305 let json_string ppf s =
306 let is_control = function
307 | '\x00' .. '\x1F' | '\x7F' -> true
308 | _ -> false
309 in
310 let len = String.length s in
311 let max_idx = len - 1 in
312 let flush ppf start i =
313 if start < len then substring start (i - start) ppf s
314 in
315 let rec loop start i =
316 if i > max_idx then flush ppf start i
317 else
318 let next = i + 1 in
319 match String.get s i with
320 | '"' ->
321 flush ppf start i;
322 string ppf "\\\"";
323 loop next next
324 | '\\' ->
325 flush ppf start i;
326 string ppf "\\\\";
327 loop next next
328 | '\n' ->
329 flush ppf start i;
330 string ppf "\\n";
331 loop next next
332 | '\r' ->
333 flush ppf start i;
334 string ppf "\\r";
335 loop next next
336 | '\t' ->
337 flush ppf start i;
338 string ppf "\\t";
339 loop next next
340 | c when is_control c ->
341 flush ppf start i;
342 string ppf (Fmt.str "\\u%04X" (Char.code c));
343 loop next next
344 | _c -> loop start next
345 in
346 char ppf '"';
347 loop 0 0;
348 char ppf '"'
349end
350
351(* JSON numbers *)
352
353module Number = struct
354 let number_contains_int = Sys.int_size <= 53
355 let min_exact_int = if number_contains_int then Int.min_int else -(1 lsl 53)
356 let max_exact_int = if number_contains_int then Int.max_int else 1 lsl 53
357 let min_exact_uint8 = 0
358 let max_exact_uint8 = 255
359 let min_exact_uint16 = 0
360 let max_exact_uint16 = 65535
361 let min_exact_int8 = -128
362 let max_exact_int8 = 127
363 let min_exact_int16 = -32768
364 let max_exact_int16 = 32767
365 let min_exact_int32 = Int32.min_int
366 let max_exact_int32 = Int32.max_int
367 let max_exact_int64 = Int64.shift_left 1L 53
368 let min_exact_int64 = Int64.neg max_exact_int64
369 let[@inline] int_is_uint8 v = v land lnot 0xFF = 0
370 let[@inline] int_is_uint16 v = v land lnot 0xFFFF = 0
371 let[@inline] int_is_int8 v = min_exact_int8 <= v && v <= max_exact_int8
372 let[@inline] int_is_int16 v = min_exact_int16 <= v && v <= max_exact_int16
373 let[@inline] can_store_exact_int v = min_exact_int <= v && v <= max_exact_int
374
375 let[@inline] can_store_exact_int64 v =
376 Int64.(compare min_exact_int64 v <= 0 && compare v max_exact_int64 <= 0)
377
378 let max_exact_int_float = Int.to_float max_exact_int
379 let min_exact_int_float = Int.to_float min_exact_int
380 let max_exact_uint8_float = Int.to_float max_exact_uint8
381 let min_exact_uint8_float = Int.to_float min_exact_uint8
382 let max_exact_uint16_float = Int.to_float max_exact_uint16
383 let min_exact_uint16_float = Int.to_float min_exact_uint16
384 let max_exact_int8_float = Int.to_float max_exact_int8
385 let min_exact_int8_float = Int.to_float min_exact_int8
386 let min_exact_int16_float = Int.to_float min_exact_int16
387 let max_exact_int16_float = Int.to_float max_exact_int16
388 let max_exact_int32_float = Int32.to_float max_exact_int32
389 let min_exact_int32_float = Int32.to_float min_exact_int32
390 let max_exact_int64_float = Int64.to_float max_exact_int64
391 let min_exact_int64_float = Int64.to_float min_exact_int64
392
393 let[@inline] in_exact_int_range v =
394 min_exact_int_float <= v && v <= max_exact_int_float
395
396 let[@inline] in_exact_uint8_range v =
397 min_exact_uint8_float <= v && v <= max_exact_uint8_float
398
399 let[@inline] in_exact_uint16_range v =
400 min_exact_uint16_float <= v && v <= max_exact_uint16_float
401
402 let[@inline] in_exact_int8_range v =
403 min_exact_int8_float <= v && v <= max_exact_int8_float
404
405 let[@inline] in_exact_int16_range v =
406 min_exact_int16_float <= v && v <= max_exact_int16_float
407
408 let[@inline] in_exact_int32_range v =
409 min_exact_int32_float <= v && v <= max_exact_int32_float
410
411 let[@inline] in_exact_int64_range v =
412 min_exact_int64_float <= v && v <= max_exact_int64_float
413end
414
415(* JSON Paths *)