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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
(*─────────────────────────────────────────────────────────────────────────────┐
│ 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 KDL = struct
let of_flow flow =
try
Eio.Buf_read.parse_exn
(fun buf -> Eio.Buf_read.take_all buf |> Kdl.of_string)
~max_size: max_int
flow
with
| exn -> failwith (Printexc.to_string exn)
let to_flow flow doc =
Eio.Buf_write.with_flow flow @@ fun buf ->
let out_string s off len =
String.sub s off len |> Eio.Buf_write.string buf
in
let flush () = () in
let ppf = Format.make_formatter out_string flush in
(* replace spaces with tabs for indentation *)
let base_fmt = Format.pp_get_formatter_out_functions ppf () 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 ppf tabbed_fmt;
(* enable utf-8 and pretty-print *)
Fmt.set_utf_8 ppf true;
Kdl.pp ppf doc;
Format.pp_print_flush ppf ()
module L = Kdl_lens_result
module Valid = struct
type err = [
| L.lerr
| `ParseError of Kdl.error
| `OneRequired of string list
| `OnlyOneOf of string list
| `InvalidLatestCmd of string
| `InvalidHashAlgorithm of string
]
[@@deriving show]
type 'a t = ('a, err list) result
let pp ~(ok : 'a Fmt.t) : 'a t Fmt.t =
Fmt.result ~ok ~error: (Fmt.list pp_err)
let map = Result.map
let map1 (f : 'a -> 'b) (vx : ('a, err) result) : 'b t =
match vx with
| Ok x -> Ok (f x)
| Error e -> Error [e]
let map_error = Result.map_error
let pure x = Ok x
let and_map (vx : 'a t) (vf : ('a -> 'b) t) =
match vx, vf with
| Ok x, Ok f -> Ok (f x)
| Error e, Ok _ -> Error e
| Ok _, Error e -> Error e
| Error e1, Error e2 -> Error (e2 @ e1)
let product (vx : 'a t) (vy : 'b t) =
match vx, vy with
| Ok x, Ok y -> Ok (x, y)
| Error e, Ok _ -> Error e
| Ok _, Error e -> Error e
| Error e1, Error e2 -> Error (e2 @ e1)
let and_map1 (vx : ('a, err) result) (vf : ('a -> 'b) t) =
match vx, vf with
| Ok x, Ok f -> Ok (f x)
| Error e, Ok _ -> Error [e]
| Ok _, Error e -> Error e
| Error e1, Error e2 -> Error (e2 @ [e1])
let bind = Result.bind
let lift_lens (r : ('a, L.lerr) result) : ('a, err list) result =
Result.map_error (fun e -> ([e] :> err list)) r
let ll = lift_lens
let (let+) vx f = map f vx
let (and+) = product
let (let*) = bind
end
type 'a codec = {
to_kdl: 'a -> Kdl.t;
of_kdl: Kdl.t -> 'a Valid.t
}
type 'a node_codec = {
to_node: 'a -> Kdl.node;
of_node: Kdl.node -> 'a Valid.t
}
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 URI = struct
let jsont : Uri.t Jsont.t =
Jsont.string
|> Jsont.map ~kind: "URI" ~dec: Uri.of_string ~enc: Uri.to_string
end
|
