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
|
(*─────────────────────────────────────────────────────────────────────────────┐
│ SPDX-FileCopyrightText: 2025 toastal <https://toast.al/contact/> │
│ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception │
└─────────────────────────────────────────────────────────────────────────────*)
(* extend & fix casing for ocaml-kdl *)
include Kdl
let of_flow flow : (t, [> `ParseError of string]) result =
try
match Eio.Buf_read.parse_exn
(fun buf -> Eio.Buf_read.take_all buf |> Kdl.of_string)
~max_size: max_int
flow
with
| Ok doc -> Ok doc
| Error _ -> Error (`ParseError "KDL parse error")
with
| Kdl.Parse_error (msg, _) -> Error (`ParseError msg)
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;
pp ppf doc;
Format.pp_print_flush ppf ()
module L = KDL_lens_result
module Valid = struct
type err = [
| L.lerr
| `ParseError of string
| `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 -> t;
of_kdl: t -> 'a Valid.t
}
type 'a node_codec = {
to_node: 'a -> node;
of_node: node -> 'a Valid.t
}
|
