1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
(*─────────────────────────────────────────────────────────────────────────────┐
│ SPDX-FileCopyrightText: 2025 toastal <https://toast.al/contact/> │
│ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception │
└─────────────────────────────────────────────────────────────────────────────*)
module Formatter = struct
let to_flow pp flow =
let buffer = Buffer.create 4096 in
let fmt = Format.formatter_of_buffer buffer in
pp fmt;
Format.pp_print_flush fmt ();
Eio.Flow.copy_string (Buffer.contents buffer) flow
end
module Jsont = struct
include Jsont
let encode_tag tag_code encoder v = [|
(Json.encode uint8) tag_code |> Result.get_ok;
Json.encode encoder v |> Result.get_ok;
|]
let pp_piset fmt json =
let rec pp_value fmt = function
| Jsont.Null _ -> Fmt.pf fmt "%a" Jsont.pp_null ()
| Jsont.Bool (b, _) -> Fmt.pf fmt "%a" Jsont.pp_bool b
| Jsont.Number (f, _) -> Fmt.pf fmt "%a" Jsont.pp_number f
| Jsont.String (s, _) -> Fmt.pf fmt "%a" Jsont.pp_string s
| Jsont.Array (arr, _) ->
Fmt.pf fmt "@[<hov>[%a]@]" (Fmt.list ~sep: (Fmt.any ",@ ") pp_value) arr
| Jsont.Object (obj, _) ->
let pp_mem fmt ((k, _), v) =
Fmt.pf fmt "@[<hv>%a: %a@]" Jsont.pp_string k pp_value v
in
Fmt.pf fmt "@[<hv>{@;<0 1>%a@;<0 0>}@]" (Fmt.list ~sep: (Fmt.any ",@ ") pp_mem) obj
in
pp_value fmt json
let of_flow codec flow =
try
let buf = Eio.Buf_read.of_flow flow ~max_size: max_int in
let str = Eio.Buf_read.take_all buf in
Jsont_bytesrw.decode_string codec str
with
| exn -> Error (Printexc.to_string exn)
let to_flow codec value flow =
match Jsont_bytesrw.encode_string codec value with
| Ok str ->
Eio.Flow.copy_string str flow;
Ok ()
| Error err -> Error err
let to_flow_piset codec value flow =
match Jsont.Json.encode codec value with
| Ok json ->
let buffer = Buffer.create 4096 in
let fmt = Format.formatter_of_buffer buffer in
let base_fmt = Format.pp_get_formatter_out_functions fmt () in
let tabbed_fmt = {base_fmt with
out_indent = (fun n -> base_fmt.out_string (String.make n '\t') 0 n)
}
in
Format.pp_set_formatter_out_functions fmt tabbed_fmt;
pp_piset fmt json;
Format.pp_print_flush fmt ();
Eio.Flow.copy_string (Buffer.contents buffer) flow;
Ok ()
| Error err -> Error err
end
module These = struct
type ('a, 'b) t =
| This of 'a
| That of 'b
| These of 'a * 'b
[@@deriving show]
let map_both f g = function
| This a -> This (f a)
| That b -> That (g b)
| These (a, b) -> These (f a, g b)
let map_this f =
map_both f Fun.id
let map_that g =
map_both Fun.id g
let these f g h = function
| This a -> f a
| That b -> g b
| These (a, b) -> h a b
let merge h =
these Fun.id Fun.id h
let merge_with h f g =
these f g (fun a b -> h (f a) (g b))
end
module Non_empty_list = struct
type 'a t =
('a * 'a list)
[@@deriving show, eq, qcheck]
let to_list (x, xs) = x :: xs
let of_list = function
| [] -> None
| x :: xs -> Some (x, xs)
let map f (x, xs) = (f x, List.map f xs)
let fold_left f acc (x, xs) = List.fold_left f acc (x :: xs)
let fold_right f acc (x, xs) = List.fold_right f acc (x :: xs)
end
|
