My own corner of monopam
claude: complete Err -> Error module rename across call sites
Follow up to the module rename: update the remaining callers that
still referenced [Err] (library [claude.ml{,i}], [client.ml], the test
driver [test.ml]), and fix one stray [^ e] string concatenation in
hermest's CLI that needed [Json.Error.to_string e] now that
[Json.of_string] yields a structured error.
+3165
-3129
+5
bottler/lib/config.ml
+5
bottler/lib/config.ml
+5
bottler/lib/config.mli
+5
bottler/lib/config.mli
···
42
42
43
43
val load : string -> (t, string) result
44
44
(** [load path] reads the YAML config at [path]. *)
45
+
46
+
val pp : t Fmt.t
47
+
(** [pp] renders a human-readable summary of a config: handle, tap push URL, and
48
+
package count. Secrets (Scaleway credentials) never reach {!t}, so the
49
+
summary is safe to log. *)
+18
-1
bottler/lib/errors.mli
+18
-1
bottler/lib/errors.mli
···
35
35
isn't present in [Formula/]. *)
36
36
37
37
val pp : t Fmt.t
38
-
(** [pp ppf err] formats [err] as a single user-facing line. *)
38
+
(** [pp] formats an error as a single user-facing line. *)
39
39
40
40
val to_string : t -> string
41
41
(** [to_string err] is {!pp} rendered to a string. *)
···
47
47
consistent. *)
48
48
49
49
val err_not_found : string -> ('a, string) result
50
+
(** [err_not_found name] reports [name] missing from [$PATH]. *)
51
+
50
52
val err_parse : string -> ('a, string) result
53
+
(** [err_parse msg] reports [homebrew.yml] parse failure with [msg]. *)
54
+
51
55
val err_scaleway : string -> ('a, string) result
56
+
(** [err_scaleway msg] reports a Scaleway profile load failure. *)
57
+
52
58
val err_tar_unix : Unix.error -> ('a, string) result
59
+
(** [err_tar_unix u] wraps a [Unix.error] from [ocaml-tar] archive I/O. *)
60
+
53
61
val err_tar_fatal : Tar.error -> ('a, string) result
62
+
(** [err_tar_fatal e] wraps a fatal structural error from [ocaml-tar]. *)
63
+
54
64
val err_brew : string -> string -> ('a, string) result
65
+
(** [err_brew args msg] reports that [brew args] exited non-zero. *)
66
+
55
67
val err_no_bottle : string -> ('a, string) result
68
+
(** [err_no_bottle name] reports that the build for [name] did not produce an
69
+
installable bottle. *)
70
+
56
71
val err_no_formula : string -> ('a, string) result
72
+
(** [err_no_formula name] reports that [Formula/<name>.rb] is absent from the
73
+
tap -- raised by tap-level operations like {!Remove.run}. *)
+1
-1
bottler/test/dune
+1
-1
bottler/test/dune
-23
bottler/test/sample.ml
-23
bottler/test/sample.ml
···
1
-
let config : Bottler.Config.t =
2
-
{
3
-
handle = "test.example";
4
-
mono_url = "https://example.com/mono.git";
5
-
license = "ISC";
6
-
storage =
7
-
{
8
-
bucket = "test-bottles";
9
-
region = "us-east";
10
-
profile = "test";
11
-
endpoint = "https://s3.us-east.scw.cloud";
12
-
rclone_remote = "scaleway";
13
-
};
14
-
tap =
15
-
{
16
-
clone_url = "https://example.com/tap.git";
17
-
push_url = "git@example.com:tap";
18
-
local_path = "../tap";
19
-
};
20
-
build = { linux = Static };
21
-
packages = [];
22
-
build_dir = "_build";
23
-
}
-2
bottler/test/sample.mli
-2
bottler/test/sample.mli
+1
-1
bottler/test/test_formula.ml
+1
-1
bottler/test/test_formula.ml
···
13
13
conflicts_with = [];
14
14
}
15
15
in
16
-
let formula = Bottler.Formula.of_package Sample.config pkg in
16
+
let formula = Bottler.Formula.of_package Test_helpers.config pkg in
17
17
Alcotest.(check string) "name" "myapp" formula.name;
18
18
Alcotest.(check int) "bottle count" 3 (List.length formula.bottles);
19
19
let ruby = Homebrew.Formula.to_ruby formula in
+1
bottler/test/test_formula.mli
+1
bottler/test/test_formula.mli
+1
bottler/test/test_list.mli
+1
bottler/test/test_list.mli
+1
bottler/test/test_readme.mli
+1
bottler/test/test_readme.mli
+1
bottler/test/test_remove.mli
+1
bottler/test/test_remove.mli
-8
bottler/test/test_retry.ml
-8
bottler/test/test_retry.ml
···
4
4
and a [local_path] that doesn't exist -- the [reset_to_remote] call will
5
5
fail, aborting the retry, which is what we check below. *)
6
6
7
-
let failing_twice_then_ok () =
8
-
let attempts = ref 0 in
9
-
fun () ->
10
-
incr attempts;
11
-
if !attempts < 3 then Error (Fmt.str "attempt %d failed" !attempts)
12
-
else Ok ()
13
-
14
7
let test_success_on_first () =
15
8
let f () = Ok () in
16
9
match
···
39
32
(unit, string) result) =
40
33
Bottler.Retry.with_tap_push
41
34
in
42
-
let _ = failing_twice_then_ok in
43
35
()
44
36
45
37
let suite =
+1
bottler/test/test_retry.mli
+1
bottler/test/test_retry.mli
+2
-1
bottler/test/test_url.ml
+2
-1
bottler/test/test_url.ml
+2
-2
bottler/test/test_workflow.ml
+2
-2
bottler/test/test_workflow.ml
···
1
1
let test_static () =
2
-
let yaml = Bottler.Workflow.generate Sample.config in
2
+
let yaml = Bottler.Workflow.generate Test_helpers.config in
3
3
Alcotest.(check bool)
4
4
"alpine container" true
5
5
(Astring.String.is_infix ~affix:"ocaml/opam:alpine" yaml);
···
8
8
(Astring.String.is_infix ~affix:"OCAMLPARAM=_,ccopt=-static" yaml)
9
9
10
10
let test_linuxbrew () =
11
-
let config = { Sample.config with build = { linux = Linuxbrew } } in
11
+
let config = { Test_helpers.config with build = { linux = Linuxbrew } } in
12
12
let yaml = Bottler.Workflow.generate config in
13
13
Alcotest.(check bool)
14
14
"homebrew container" true
+1
-2
dune-project
+1
-2
dune-project
+1
-2
dupfind/dune-project
+1
-2
dupfind/dune-project
+1
-1
dupfind/dupfind.opam
+1
-1
dupfind/dupfind.opam
+1
-1
dupfind/lib/dune
+1
-1
dupfind/lib/dune
+1
-2
irmin/bin/dune
+1
-2
irmin/bin/dune
+1
-2
irmin/test/test_worktree.ml
+1
-2
irmin/test/test_worktree.ml
···
67
67
W.commit ~fs heap ~branch:"main" ~dir ~message:"init" ~author:"test"
68
68
with
69
69
| Ok _hash -> ()
70
-
| Error (`Msg e) ->
71
-
Alcotest.failf "commit failed: %s" e);
70
+
| Error (`Msg e) -> Alcotest.failf "commit failed: %s" e);
72
71
(* Status should be clean after commit *)
73
72
let changes = W.status ~fs ~dir in
74
73
Alcotest.(check int) "clean after commit" 0 (List.length changes);
-1
kdf/hkdf/dune
-1
kdf/hkdf/dune
-1
kdf/scrypt/dune
-1
kdf/scrypt/dune
+2
-2
merlint/docs/index.html
+2
-2
merlint/docs/index.html
···
1451
1451
<h4>BAD</h4>
1452
1452
<pre><code><span class="kw">let</span> test_parse () =
1453
1453
<span class="kw">match</span> parse input <span class="kw">with</span>
1454
-
| <span class="cn">Error</span> e -> <span class="cn">Alcotest</span>.fail (<span class="cn">Fmt</span>.str "<span class="cn">Parse</span> error: %s" e)
1454
+
| <span class="cn">Error</span> e -> <span class="cn">Alcotest</span>.fail (<span class="cn">Fmt</span>.str "<span class="cn">Parse</span> error: %s" (<span class="cn">Json</span>.<span class="cn">Error</span>.to_string e))
1455
1455
| <span class="cn">Ok</span> _ -> ()
1456
1456
1457
1457
<span class="kw">let</span> test_invalid () =
···
1462
1462
<h4>GOOD</h4>
1463
1463
<pre><code><span class="kw">let</span> test_parse () =
1464
1464
<span class="kw">match</span> parse input <span class="kw">with</span>
1465
-
| <span class="cn">Error</span> e -> <span class="cn">Alcotest</span>.failf "<span class="cn">Parse</span> error: %s" e
1465
+
| <span class="cn">Error</span> e -> <span class="cn">Alcotest</span>.failf "<span class="cn">Parse</span> error: %s" (<span class="cn">Json</span>.<span class="cn">Error</span>.to_string e)
1466
1466
| <span class="cn">Ok</span> _ -> ()
1467
1467
1468
1468
<span class="kw">let</span> test_invalid () =
+1
-2
merlint/dune-project
+1
-2
merlint/dune-project
+1
-2
merlint/lib/dune
+1
-2
merlint/lib/dune
+2
-2
merlint/lib/rules/e325.ml
+2
-2
merlint/lib/rules/e325.ml
···
23
23
24
24
(** Stdlib-aligned [find_*] names whose return shape is a collection (not an
25
25
option): [List.find_all], [Hashtbl.find_all], etc. The name-shape is a
26
-
stable signal (the stdlib enshrines the convention); do not flag these
27
-
for returning a non-option. *)
26
+
stable signal (the stdlib enshrines the convention); do not flag these for
27
+
returning a non-option. *)
28
28
let is_stdlib_find_collection_name name =
29
29
name = "find_all" || name = "find_many"
30
30
+4
-4
merlint/lib/rules/e331.ml
+4
-4
merlint/lib/rules/e331.ml
···
1
1
(** E331: Redundant Function Prefixes *)
2
2
3
-
(** Stdlib-aligned [find_*] names where stripping the [find_] prefix would
4
-
lose information: [List.find_all], [Hashtbl.find_all], [List.find_map],
5
-
etc. The bare suffix ([all], [map]) alone isn't descriptive enough, and
6
-
the stdlib precedent establishes the full name as the natural form. *)
3
+
(** Stdlib-aligned [find_*] names where stripping the [find_] prefix would lose
4
+
information: [List.find_all], [Hashtbl.find_all], [List.find_map], etc. The
5
+
bare suffix ([all], [map]) alone isn't descriptive enough, and the stdlib
6
+
precedent establishes the full name as the natural form. *)
7
7
let is_stdlib_find_alias name =
8
8
name = "find_all" || name = "find_map" || name = "find_many"
9
9
|| name = "find_index" || name = "find_last" || name = "find_first"
+53
-5
merlint/lib/rules/e522.ml
+53
-5
merlint/lib/rules/e522.ml
···
17
17
18
18
type payload = { package : string; file : string }
19
19
20
+
let try_readdir d = try Sys.readdir d |> Array.to_list with Sys_error _ -> []
21
+
22
+
let read_file path =
23
+
try
24
+
let ic = open_in path in
25
+
let n = in_channel_length ic in
26
+
let s = really_input_string ic n in
27
+
close_in ic;
28
+
Some s
29
+
with Sys_error _ -> None
30
+
31
+
(** Collect every module name that appears in a [(modules ...)] field of a
32
+
library/executable/test stanza in [dune_path]. These names are claimed by a
33
+
specific stanza (often a sublibrary) and should not be flagged as "wrong
34
+
place" by E522 — the prefix is encoding the sublib's public name. *)
35
+
let modules_explicitly_claimed dune_path =
36
+
match read_file dune_path with
37
+
| None -> []
38
+
| Some contents -> (
39
+
match Sexp.Value.parse_string_many contents with
40
+
| Error _ -> []
41
+
| Ok stanzas ->
42
+
let is_module_stanza = function
43
+
| "library" | "executable" | "executables" | "test" | "tests" ->
44
+
true
45
+
| _ -> false
46
+
in
47
+
List.concat_map
48
+
(function
49
+
| Sexp.List (Sexp.Atom kind :: fields) when is_module_stanza kind
50
+
->
51
+
List.concat_map
52
+
(function
53
+
| Sexp.List (Sexp.Atom "modules" :: atoms) ->
54
+
List.filter_map
55
+
(function
56
+
| Sexp.Atom a -> Some (String.lowercase_ascii a)
57
+
| _ -> None)
58
+
atoms
59
+
| _ -> [])
60
+
fields
61
+
| _ -> [])
62
+
stanzas)
63
+
20
64
let check (ctx : Context.project) =
21
65
let root = ctx.project_root in
22
-
let try_readdir d =
23
-
try Sys.readdir d |> Array.to_list with Sys_error _ -> []
24
-
in
25
66
let issues = ref [] in
26
67
let packages = try_readdir root in
27
68
List.iter
···
42
83
(* Dune mangles [-] to [_] in module names. *)
43
84
String.map (fun c -> if c = '-' then '_' else c) p ^ "_"
44
85
in
86
+
let claimed =
87
+
modules_explicitly_claimed (Filename.concat lib_dir "dune")
88
+
in
45
89
let has_ml name = Filename.check_suffix name ".ml" in
46
90
List.iter
47
91
(fun name ->
···
50
94
&& String.length name > String.length prefix + 3
51
95
&& String.sub name 0 (String.length prefix) = prefix
52
96
then
53
-
let path = Filename.concat (Filename.concat pkg "lib") name in
54
-
issues := Issue.v { package = pkg; file = path } :: !issues)
97
+
let mod_name =
98
+
String.lowercase_ascii (Filename.chop_suffix name ".ml")
99
+
in
100
+
if not (List.mem mod_name claimed) then
101
+
let path = Filename.concat (Filename.concat pkg "lib") name in
102
+
issues := Issue.v { package = pkg; file = path } :: !issues)
55
103
(try_readdir lib_dir))
56
104
packages;
57
105
!issues
+2
-2
merlint/lib/rules/e616.ml
+2
-2
merlint/lib/rules/e616.ml
···
49
49
code =
50
50
{|let test_parse () =
51
51
match parse input with
52
-
| Error e -> Alcotest.fail (Fmt.str "Parse error: %s" e)
52
+
| Error e -> Alcotest.fail (Fmt.str "Parse error: %s" (Json.Error.to_string e))
53
53
| Ok _ -> ()
54
54
55
55
let test_invalid () =
···
61
61
code =
62
62
{|let test_parse () =
63
63
match parse input with
64
-
| Error e -> Alcotest.failf "Parse error: %s" e
64
+
| Error e -> Alcotest.failf "Parse error: %s" (Json.Error.to_string e)
65
65
| Ok _ -> ()
66
66
67
67
let test_invalid () =
+1
-1
merlint/merlint.opam
+1
-1
merlint/merlint.opam
+1
-1
merlint/test/cram/e001.t/dune
+1
-1
merlint/test/cram/e001.t/dune
+1
-1
merlint/test/cram/e005.t/dune
+1
-1
merlint/test/cram/e005.t/dune
+1
-1
merlint/test/cram/e010.t/dune
+1
-1
merlint/test/cram/e010.t/dune
+1
-1
merlint/test/cram/e100.t/dune
+1
-1
merlint/test/cram/e100.t/dune
+1
-1
merlint/test/cram/e105.t/dune
+1
-1
merlint/test/cram/e105.t/dune
+1
-1
merlint/test/cram/e110.t/dune
+1
-1
merlint/test/cram/e110.t/dune
-1
merlint/test/cram/e200.t/dune
-1
merlint/test/cram/e200.t/dune
-1
merlint/test/cram/e205.t/dune
-1
merlint/test/cram/e205.t/dune
-1
merlint/test/cram/e210.t/dune
-1
merlint/test/cram/e210.t/dune
-1
merlint/test/cram/e215.t/dune
-1
merlint/test/cram/e215.t/dune
-1
merlint/test/cram/e216.t/dune
-1
merlint/test/cram/e216.t/dune
+1
-1
merlint/test/cram/e300.t/dune
+1
-1
merlint/test/cram/e300.t/dune
+1
-1
merlint/test/cram/e305.t/dune
+1
-1
merlint/test/cram/e305.t/dune
+1
-1
merlint/test/cram/e310.t/dune
+1
-1
merlint/test/cram/e310.t/dune
+1
-1
merlint/test/cram/e315.t/dune
+1
-1
merlint/test/cram/e315.t/dune
+1
-1
merlint/test/cram/e320.t/dune
+1
-1
merlint/test/cram/e320.t/dune
+1
-1
merlint/test/cram/e325.t/dune
+1
-1
merlint/test/cram/e325.t/dune
+1
-1
merlint/test/cram/e335.t/dune
+1
-1
merlint/test/cram/e335.t/dune
-1
merlint/test/cram/e340.t/dune
-1
merlint/test/cram/e340.t/dune
-1
merlint/test/cram/e350.t/dune
-1
merlint/test/cram/e350.t/dune
-1
merlint/test/cram/e351.t/dune
-1
merlint/test/cram/e351.t/dune
+1
-1
merlint/test/cram/e400.t/dune
+1
-1
merlint/test/cram/e400.t/dune
+1
-1
merlint/test/cram/e405.t/dune
+1
-1
merlint/test/cram/e405.t/dune
-1
merlint/test/cram/e410.t/dune
-1
merlint/test/cram/e410.t/dune
-1
merlint/test/cram/e415.t/dune
-1
merlint/test/cram/e415.t/dune
+1
-1
merlint/test/cram/e500.t/bad/dune
+1
-1
merlint/test/cram/e500.t/bad/dune
+1
-1
merlint/test/cram/e500.t/good/dune
+1
-1
merlint/test/cram/e500.t/good/dune
+1
-1
merlint/test/cram/e505.t/dune
+1
-1
merlint/test/cram/e505.t/dune
-1
merlint/test/cram/e510.t/dune
-1
merlint/test/cram/e510.t/dune
-1
merlint/test/cram/e600.t/bad/dune
-1
merlint/test/cram/e600.t/bad/dune
-1
merlint/test/cram/e600.t/good/dune
-1
merlint/test/cram/e600.t/good/dune
+1
-1
merlint/test/cram/e607.t/bad/lib/core/dune
+1
-1
merlint/test/cram/e607.t/bad/lib/core/dune
+1
-1
merlint/test/cram/e607.t/bad/lib/views/dune
+1
-1
merlint/test/cram/e607.t/bad/lib/views/dune
+1
-1
merlint/test/cram/e607.t/good/lib/core/dune
+1
-1
merlint/test/cram/e607.t/good/lib/core/dune
+1
-1
merlint/test/cram/e610.t/bad/test/dune
+1
-1
merlint/test/cram/e610.t/bad/test/dune
+1
-1
merlint/test/cram/e610.t/good-subdir/test/dune
+1
-1
merlint/test/cram/e610.t/good-subdir/test/dune
+1
-1
merlint/test/cram/e610.t/good/test/dune
+1
-1
merlint/test/cram/e610.t/good/test/dune
-1
merlint/test/cram/e615.t/bad/test/dune
-1
merlint/test/cram/e615.t/bad/test/dune
-1
merlint/test/cram/e615.t/good/test/dune
-1
merlint/test/cram/e615.t/good/test/dune
-1
merlint/test/cram/e616.t/dune
-1
merlint/test/cram/e616.t/dune
-1
merlint/test/cram/e617.t/dune
-1
merlint/test/cram/e617.t/dune
-1
merlint/test/cram/e617.t/good/dune
-1
merlint/test/cram/e617.t/good/dune
+1
-1
merlint/test/cram/e618.t/bad/dune
+1
-1
merlint/test/cram/e618.t/bad/dune
-1
merlint/test/cram/e618.t/bad/test/dune
-1
merlint/test/cram/e618.t/bad/test/dune
+1
-1
merlint/test/cram/e618.t/good/dune
+1
-1
merlint/test/cram/e618.t/good/dune
-1
merlint/test/cram/e618.t/good/test/dune
-1
merlint/test/cram/e618.t/good/test/dune
+1
-1
merlint/test/cram/e620.t/bad/dune
+1
-1
merlint/test/cram/e620.t/bad/dune
+1
-1
merlint/test/cram/e620.t/good/dune
+1
-1
merlint/test/cram/e620.t/good/dune
+1
-1
merlint/test/cram/e621.t/bad/dune
+1
-1
merlint/test/cram/e621.t/bad/dune
+1
-1
merlint/test/cram/e621.t/good/dune
+1
-1
merlint/test/cram/e621.t/good/dune
+1
-1
merlint/test/cram/e700.t/bad/dune
+1
-1
merlint/test/cram/e700.t/bad/dune
-1
merlint/test/cram/e700.t/bad/fuzz/dune
-1
merlint/test/cram/e700.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e700.t/good/dune
+1
-1
merlint/test/cram/e700.t/good/dune
-1
merlint/test/cram/e700.t/good/fuzz/dune
-1
merlint/test/cram/e700.t/good/fuzz/dune
+1
-1
merlint/test/cram/e705.t/bad/dune
+1
-1
merlint/test/cram/e705.t/bad/dune
-1
merlint/test/cram/e705.t/bad/fuzz/dune
-1
merlint/test/cram/e705.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e705.t/good/dune
+1
-1
merlint/test/cram/e705.t/good/dune
-1
merlint/test/cram/e705.t/good/fuzz/dune
-1
merlint/test/cram/e705.t/good/fuzz/dune
+1
-1
merlint/test/cram/e710.t/bad/dune
+1
-1
merlint/test/cram/e710.t/bad/dune
-1
merlint/test/cram/e710.t/bad/fuzz/dune
-1
merlint/test/cram/e710.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e710.t/good/dune
+1
-1
merlint/test/cram/e710.t/good/dune
-1
merlint/test/cram/e710.t/good/fuzz/dune
-1
merlint/test/cram/e710.t/good/fuzz/dune
+1
-1
merlint/test/cram/e715.t/bad/dune
+1
-1
merlint/test/cram/e715.t/bad/dune
-1
merlint/test/cram/e715.t/bad/fuzz/dune
-1
merlint/test/cram/e715.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e715.t/good/dune
+1
-1
merlint/test/cram/e715.t/good/dune
-1
merlint/test/cram/e715.t/good/fuzz/dune
-1
merlint/test/cram/e715.t/good/fuzz/dune
+1
-1
merlint/test/cram/e718.t/bad/dune
+1
-1
merlint/test/cram/e718.t/bad/dune
-1
merlint/test/cram/e718.t/bad/fuzz/dune
-1
merlint/test/cram/e718.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e718.t/good/dune
+1
-1
merlint/test/cram/e718.t/good/dune
+1
-1
merlint/test/cram/e720.t/bad/dune
+1
-1
merlint/test/cram/e720.t/bad/dune
+1
-1
merlint/test/cram/e720.t/good/dune
+1
-1
merlint/test/cram/e720.t/good/dune
-1
merlint/test/cram/e720.t/good/fuzz/dune
-1
merlint/test/cram/e720.t/good/fuzz/dune
+1
-1
merlint/test/cram/e721.t/bad/dune
+1
-1
merlint/test/cram/e721.t/bad/dune
+1
-1
merlint/test/cram/e721.t/good/dune
+1
-1
merlint/test/cram/e721.t/good/dune
+1
-1
merlint/test/cram/e722.t/bad/dune
+1
-1
merlint/test/cram/e722.t/bad/dune
-1
merlint/test/cram/e722.t/bad/fuzz/dune
-1
merlint/test/cram/e722.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e722.t/good/dune
+1
-1
merlint/test/cram/e722.t/good/dune
-1
merlint/test/cram/e722.t/good/fuzz/dune
-1
merlint/test/cram/e722.t/good/fuzz/dune
+1
-1
merlint/test/cram/e724.t/bad/dune
+1
-1
merlint/test/cram/e724.t/bad/dune
-1
merlint/test/cram/e724.t/bad/fuzz/dune
-1
merlint/test/cram/e724.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e724.t/good/dune
+1
-1
merlint/test/cram/e724.t/good/dune
-1
merlint/test/cram/e724.t/good/fuzz/dune
-1
merlint/test/cram/e724.t/good/fuzz/dune
+1
-1
merlint/test/cram/e725.t/bad/dune
+1
-1
merlint/test/cram/e725.t/bad/dune
-1
merlint/test/cram/e725.t/bad/fuzz/dune
-1
merlint/test/cram/e725.t/bad/fuzz/dune
+1
-1
merlint/test/cram/e725.t/good/dune
+1
-1
merlint/test/cram/e725.t/good/dune
-1
merlint/test/cram/e725.t/good/fuzz/dune
-1
merlint/test/cram/e725.t/good/fuzz/dune
+1
-1
merlint/test/cram/e726.t/bad/dune
+1
-1
merlint/test/cram/e726.t/bad/dune
+1
-1
merlint/test/cram/e726.t/good/dune
+1
-1
merlint/test/cram/e726.t/good/dune
+1
-1
ocaml-agent/lib/dune
+1
-1
ocaml-agent/lib/dune
+11
-11
ocaml-agent/lib/todo.ml
+11
-11
ocaml-agent/lib/todo.ml
···
18
18
| Completed -> "completed"
19
19
20
20
let jsont =
21
-
Jsont.Object.map ~kind:"todo" (fun content status active_form ->
21
+
Json.Codec.Object.map ~kind:"todo" (fun content status active_form ->
22
22
{
23
23
content = Option.value ~default:"" content;
24
24
status = status_of_string (Option.value ~default:"pending" status);
25
25
active_form = Option.value ~default:"" active_form;
26
26
})
27
-
|> Jsont.Object.opt_mem "content" Jsont.string ~enc:(fun t -> Some t.content)
28
-
|> Jsont.Object.opt_mem "status" Jsont.string ~enc:(fun t ->
27
+
|> Json.Codec.Object.opt_mem "content" Json.Codec.string ~enc:(fun t ->
28
+
Some t.content)
29
+
|> Json.Codec.Object.opt_mem "status" Json.Codec.string ~enc:(fun t ->
29
30
Some (string_of_status t.status))
30
-
|> Jsont.Object.opt_mem "activeForm" Jsont.string ~enc:(fun t ->
31
+
|> Json.Codec.Object.opt_mem "activeForm" Json.Codec.string ~enc:(fun t ->
31
32
Some t.active_form)
32
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
33
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
33
34
34
35
let todos_jsont =
35
-
Jsont.Object.map ~kind:"todos" Fun.id
36
-
|> Jsont.Object.mem "todos" (Jsont.list jsont) ~enc:Fun.id ~dec_absent:[]
37
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
36
+
Json.Codec.Object.map ~kind:"todos" Fun.id
37
+
|> Json.Codec.Object.mem "todos" (Json.Codec.list jsont) ~enc:Fun.id
38
+
~dec_absent:[]
39
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
38
40
39
41
let parse_todos tool_input =
40
42
let json = Claude.Tool_input.to_json tool_input in
41
-
match Jsont.Json.decode todos_jsont json with
42
-
| Ok todos -> todos
43
-
| Error _ -> []
43
+
match Json.decode todos_jsont json with Ok todos -> todos | Error _ -> []
44
44
45
45
let all_completed todos = List.for_all (fun t -> t.status = Completed) todos
46
46
+1
-1
ocaml-agent/test/dune
+1
-1
ocaml-agent/test/dune
-1
ocaml-aos/c/dune
-1
ocaml-aos/c/dune
-1
ocaml-aos/fuzz/dune
-1
ocaml-aos/fuzz/dune
+2
-2
ocaml-atp/xrpc-auth/test/test_xrpc_auth_session.ml
+2
-2
ocaml-atp/xrpc-auth/test/test_xrpc_auth_session.ml
···
35
35
let session = session () in
36
36
let json = Json.to_string Session.json session in
37
37
match Json.of_string Session.json json with
38
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
38
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
39
39
| Ok decoded ->
40
40
Alcotest.(check string) "access_jwt" session.access_jwt decoded.access_jwt;
41
41
Alcotest.(check string)
···
50
50
{|{"access_jwt":"a","refresh_jwt":"r","did":"did:plc:test","handle":"test.bsky.social","pds":"https://example.com","created_at":"2025-06-01T00:00:00Z"}|}
51
51
in
52
52
match Json.of_string Session.json json with
53
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
53
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
54
54
| Ok session ->
55
55
Alcotest.(check string) "access_jwt" "a" session.access_jwt;
56
56
Alcotest.(check string) "refresh_jwt" "r" session.refresh_jwt;
+1
-1
ocaml-atp/xrpc/test/dune
+1
-1
ocaml-atp/xrpc/test/dune
+14
-14
ocaml-atp/xrpc/test/test_xrpc_types.ml
+14
-14
ocaml-atp/xrpc/test/test_xrpc_types.ml
···
26
26
in
27
27
let json = Json.to_string Types.session_json session in
28
28
match Json.of_string Types.session_json json with
29
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
29
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
30
30
| Ok decoded ->
31
31
Alcotest.(check string) "access_jwt" session.access_jwt decoded.access_jwt;
32
32
Alcotest.(check string)
···
46
46
{|{"accessJwt":"access","refreshJwt":"refresh","did":"did:plc:test","handle":"test.bsky.social"}|}
47
47
in
48
48
match Json.of_string Types.session_json json with
49
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
49
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
50
50
| Ok session ->
51
51
Alcotest.(check string) "access_jwt" "access" session.access_jwt;
52
52
Alcotest.(check string) "refresh_jwt" "refresh" session.refresh_jwt;
···
66
66
{|{"accessJwt":"a","refreshJwt":"r","did":"did:plc:x","handle":"x.bsky.social","pdsUri":"https://pds.example.com","email":"x@example.com","emailConfirmed":true,"emailAuthFactor":false,"active":true,"status":"suspended"}|}
67
67
in
68
68
match Json.of_string Types.session_json json with
69
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
69
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
70
70
| Ok session ->
71
71
Alcotest.(check (option string))
72
72
"pds_uri" (Some "https://pds.example.com") session.pds_uri;
···
86
86
in
87
87
match Json.of_string Types.session_json json with
88
88
| Error e ->
89
-
Alcotest.failf "decode with didDoc failed: %s" (Json.Error.to_string e)
89
+
Alcotest.failf "decode with didDoc failed: %s" (Loc.Error.to_string e)
90
90
| Ok session ->
91
91
Alcotest.(check string) "did" "did:plc:x" session.did;
92
92
Alcotest.(check string) "handle" "x.bsky.social" session.handle
···
98
98
{|{"error":"InvalidHandle","message":"Handle must be a valid domain"}|}
99
99
in
100
100
match Json.of_string Types.error_payload_json json with
101
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
101
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
102
102
| Ok payload ->
103
103
Alcotest.(check string) "error" "InvalidHandle" payload.error;
104
104
Alcotest.(check (option string))
···
107
107
let test_error_payload_no_message () =
108
108
let json = {|{"error":"ExpiredToken"}|} in
109
109
match Json.of_string Types.error_payload_json json with
110
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
110
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
111
111
| Ok payload ->
112
112
Alcotest.(check string) "error" "ExpiredToken" payload.error;
113
113
Alcotest.(check (option string)) "message" None payload.message
···
118
118
in
119
119
let json = Json.to_string Types.error_payload_json payload in
120
120
match Json.of_string Types.error_payload_json json with
121
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
121
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
122
122
| Ok decoded ->
123
123
Alcotest.(check string) "error" payload.error decoded.error;
124
124
Alcotest.(check (option string)) "message" payload.message decoded.message
···
135
135
in
136
136
let json = Json.to_string Types.login_request_json req in
137
137
match Json.of_string Types.login_request_json json with
138
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
138
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
139
139
| Ok decoded ->
140
140
Alcotest.(check string) "identifier" req.identifier decoded.identifier;
141
141
Alcotest.(check string) "password" req.password decoded.password;
···
152
152
in
153
153
let json = Json.to_string Types.login_request_json req in
154
154
match Json.of_string Types.login_request_json json with
155
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
155
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
156
156
| Ok decoded ->
157
157
Alcotest.(check string) "identifier" "did:plc:abc123" decoded.identifier;
158
158
Alcotest.(check (option string))
···
161
161
let test_login_request_decode_json () =
162
162
let json = {|{"identifier":"alice.bsky.social","password":"pass123"}|} in
163
163
match Json.of_string Types.login_request_json json with
164
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
164
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
165
165
| Ok req ->
166
166
Alcotest.(check string) "identifier" "alice.bsky.social" req.identifier;
167
167
Alcotest.(check string) "password" "pass123" req.password;
···
173
173
{|{"identifier":"alice.bsky.social","password":"pass123","authFactorToken":"654321"}|}
174
174
in
175
175
match Json.of_string Types.login_request_json json with
176
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
176
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
177
177
| Ok req ->
178
178
Alcotest.(check (option string))
179
179
"auth_factor_token" (Some "654321") req.auth_factor_token
···
183
183
let test_empty_json_decodes_object () =
184
184
let json = {|{"key":"value","num":42}|} in
185
185
match Json.of_string Types.empty_json json with
186
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
186
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
187
187
| Ok () -> ()
188
188
189
189
let test_empty_json_decodes_array () =
190
190
let json = {|[1, 2, 3]|} in
191
191
match Json.of_string Types.empty_json json with
192
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
192
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
193
193
| Ok () -> ()
194
194
195
195
let test_empty_json_decodes_null () =
196
196
let json = "null" in
197
197
match Json.of_string Types.empty_json json with
198
-
| Error e -> Alcotest.failf "decode failed: %s" (Json.Error.to_string e)
198
+
| Error e -> Alcotest.failf "decode failed: %s" (Loc.Error.to_string e)
199
199
| Ok () -> ()
200
200
201
201
(* -- runner --------------------------------------------------------------- *)
+1
-1
ocaml-auth/auth.opam
+1
-1
ocaml-auth/auth.opam
+1
-2
ocaml-auth/dune-project
+1
-2
ocaml-auth/dune-project
-1
ocaml-auth/fuzz/dune
-1
ocaml-auth/fuzz/dune
+1
-2
ocaml-auth/lib/dune
+1
-2
ocaml-auth/lib/dune
-1
ocaml-ax25/c/dune
-1
ocaml-ax25/c/dune
-1
ocaml-ax25/fuzz/dune
-1
ocaml-ax25/fuzz/dune
-1
ocaml-block/fuzz/dune
-1
ocaml-block/fuzz/dune
-1
ocaml-bloom/fuzz/dune
-1
ocaml-bloom/fuzz/dune
-1
ocaml-bpsec/fuzz/dune
-1
ocaml-bpsec/fuzz/dune
+1
-2
ocaml-btree/lib/dune
+1
-2
ocaml-btree/lib/dune
-1
ocaml-bundle/fuzz/dune
-1
ocaml-bundle/fuzz/dune
-1
ocaml-cam/fuzz/dune
-1
ocaml-cam/fuzz/dune
-1
ocaml-cfdp/c/dune
-1
ocaml-cfdp/c/dune
-1
ocaml-cfdp/fuzz/dune
-1
ocaml-cfdp/fuzz/dune
-1
ocaml-cfdp/test/dune
-1
ocaml-cfdp/test/dune
-1
ocaml-cgr/fuzz/dune
-1
ocaml-cgr/fuzz/dune
+3
-6
ocaml-cgr/lib/cgr.ml
+3
-6
ocaml-cgr/lib/cgr.ml
···
164
164
type node_state = { arrival_time : float; predecessor : Contact.t option }
165
165
166
166
type state = {
167
-
plan : Contact_plan.t;
168
167
src : Node.t;
169
168
start_time : float;
170
169
nodes : node_state Node_map.t;
···
201
200
while not (H.is_empty heap) do
202
201
let current_time, current = H.pop_minimum heap in
203
202
let current_state =
204
-
get_node_state { plan; src; start_time = time; nodes = !nodes } current
203
+
get_node_state { src; start_time = time; nodes = !nodes } current
205
204
in
206
205
(* Lazy deletion: skip if this entry is stale *)
207
206
if
···
213
212
(fun contact ->
214
213
let neighbor = Contact.to_ contact in
215
214
let neighbor_state =
216
-
get_node_state
217
-
{ plan; src; start_time = time; nodes = !nodes }
218
-
neighbor
215
+
get_node_state { src; start_time = time; nodes = !nodes } neighbor
219
216
in
220
217
(* Can we use this contact? *)
221
218
if current_time < Contact.stop contact then begin
···
233
230
(Contact_plan.contacts_from plan current)
234
231
end
235
232
done;
236
-
{ plan; src; start_time = time; nodes = !nodes }
233
+
{ src; start_time = time; nodes = !nodes }
237
234
238
235
let init plan ~src ~time = run plan ~src ~time
239
236
+157
-65
ocaml-claude-skills/plugins/monopam/skills/git-rewrite/SKILL.md
+157
-65
ocaml-claude-skills/plugins/monopam/skills/git-rewrite/SKILL.md
···
67
67
68
68
## Tools that satisfy both constraints
69
69
70
-
| Tool | Working tree? | Needs TTY? | What it's for |
71
-
|-----------------------------------|---------------|------------|-----------------------------------------------|
72
-
| `git-x filter-paths` | No | No | Drop path globs from history (W0) |
73
-
| `git-x reword <SHA> -m MSG` | No | No | Change a commit's message in place |
74
-
| `git-x drop-commit <SHA>` | No | No | Remove a commit and re-parent descendants |
75
-
| `git-x split-commit <SHA>` | No | No | Split a bundled `git commit -a` by top-level dir |
76
-
| `git replay` | No | No | Rebase entirely in objects; outputs ref updates |
77
-
| `git commit-tree` | No | No | Build a commit object from a tree + parents |
78
-
| `git merge-tree --write-tree` | No | No | 3-way merge to a tree, no checkout |
79
-
| `git mktree` | No | No | Build a tree object from a listing |
80
-
| `git update-ref` / `--stdin` | No | No | Atomic branch tip update (batch via stdin) |
81
-
| `git rev-list` / `cat-file -p` | No | No | Read history and objects |
82
-
| ocaml-git `Repository` API | No | No | All of the above from OCaml (`Git.Filter`, `Git.Subtree`, etc.) |
83
-
| `git worktree add` + porcelain | Isolated | Depends | Last resort, fully isolated |
70
+
| Tool | Working tree? | Needs TTY? | What it's for |
71
+
|-------------------------------------------|---------------|------------|--------------------------------------------------|
72
+
| `git-x tree drop -p GLOB` | No | No | Drop path globs from history (W0) |
73
+
| `git-x commit reword <SHA> -m MSG` | No | No | Change a commit's message in place |
74
+
| `git-x commit drop <SHA>` | No | No | Remove a commit and re-parent descendants |
75
+
| `git-x commit split <SHA>` | No | No | Split a bundled `git commit -a` by top-level dir |
76
+
| `git-x commit squash <SHA>...` | No | No | Collapse a range of commits into one |
77
+
| `git-x commit sort BASE --by-<axis>` | No | No | Stable-reorder (BASE, head] to cluster by axis |
78
+
| `git replay` | No | No | Rebase entirely in objects; outputs ref updates |
79
+
| `git commit-tree` | No | No | Build a commit object from a tree + parents |
80
+
| `git merge-tree --write-tree` | No | No | 3-way merge to a tree, no checkout |
81
+
| `git mktree` | No | No | Build a tree object from a listing |
82
+
| `git update-ref` / `--stdin` | No | No | Atomic branch tip update (batch via stdin) |
83
+
| `git rev-list` / `cat-file -p` | No | No | Read history and objects |
84
+
| ocaml-git `Repository` API | No | No | All of the above from OCaml (`Git.Filter`, `Git.Rewrite`, `Git.Subtree`, etc.) |
85
+
| `git worktree add` + porcelain | Isolated | Depends | Last resort, fully isolated |
86
+
87
+
All `git-x` subcommands accept either a full 40-character SHA or a 4+
88
+
character hex prefix (odd or even length). Prefixes are disambiguated
89
+
against the repo's loose + packed objects; ambiguous prefixes return an
90
+
error listing the candidates.
84
91
85
92
The classic culprits — `git rebase -i`, `git rebase` (without
86
93
`--no-checkout`), `git checkout`, `git reset --hard`, `git stash`,
···
94
101
95
102
For dropping all entries matching one or more path globs (e.g. accidentally
96
103
committed `.cmi` / `.bak` / `.DS_Store` files, or wholesale removal of a
97
-
directory), the in-monorepo `git-x filter-paths` is the right tool. It
104
+
directory), the in-monorepo `git-x tree drop` is the right tool. It
98
105
implements the algorithm in `Git.Filter` from the `ocaml-git` package: walk
99
106
all commits reachable from the matching refs, rewrite each tree dropping
100
107
matched entries, re-parent commits, atomically swap the branch tips at the
···
105
112
git branch backup/main-$(date +%s) main
106
113
107
114
# dry run reports stats per ref without writing anything
108
-
git-x filter-paths -p '*.cmi' -p '*.bak' --dry-run
115
+
git-x tree drop -p '*.cmi' -p '*.bak' --dry-run
109
116
110
117
# actually rewrite (defaults to refs/heads/*)
111
-
git-x filter-paths -p '*.cmi' -p '*.bak'
118
+
git-x tree drop -p '*.cmi' -p '*.bak'
112
119
113
120
# restrict to a single branch
114
-
git-x filter-paths -p '*.cmi' -r refs/heads/main
121
+
git-x tree drop -p '*.cmi' -r refs/heads/main
115
122
116
123
# drop a directory recursively
117
-
git-x filter-paths -p 'old_pkg/**'
124
+
git-x tree drop -p 'old_pkg/**'
118
125
```
119
126
120
127
Glob semantics (via `Re.Glob`):
···
157
164
- The backup branch holds the original chain; `git update-ref
158
165
refs/heads/main backup/main-...` restores it instantly.
159
166
160
-
For arbitrary commit-by-commit rewrites (reword, drop, reorder, squash),
161
-
fall through to W1-W4 below.
167
+
For commit-by-commit rewrites (reword, drop, split, squash, sort), reach
168
+
for the `git-x commit` subcommands in W0b first; W1-W4 are the plumbing
169
+
fallbacks when you need more control.
162
170
163
-
### W0b. Single-commit edits (reword / drop / split-commit)
171
+
### W0b. Single-commit edits (reword / drop / split / squash / sort)
164
172
165
-
For one-off surgery on a specific commit, `git-x` provides three
173
+
For one-off surgery on a specific commit — or for the common
174
+
"tidy-a-messy-branch" pipeline — `git-x commit` provides five
166
175
purpose-built subcommands. Each operates purely on the object database
167
176
and atomically swings the branch ref; the working tree, index, and HEAD
168
-
are not touched.
177
+
are not touched. Each accepts full 40-char SHAs or 4+ char hex prefixes.
169
178
170
179
**Reword** — change a commit's message:
171
180
172
181
```sh
173
-
git-x reword <SHA> -m "better message describing the why"
182
+
git-x commit reword <SHA> -m "better message describing the why"
174
183
# default: --ref refs/heads/main; descendants are re-parented onto the
175
184
# new commit. Errors out if SHA isn't reachable from --ref.
176
185
```
···
178
187
**Drop** — remove a commit and re-parent its descendants:
179
188
180
189
```sh
181
-
git-x drop-commit <SHA>
190
+
git-x commit drop <SHA>
182
191
# Refuses to drop root commits and merge commits (those need explicit
183
192
# topology decisions; see W2 for `git replay --onto`).
184
193
```
185
194
186
-
**Split-commit** — un-bundle a `git commit -a` that touched several
195
+
**Split** — un-bundle a `git commit -a` that touched several
187
196
top-level directories:
188
197
189
198
```sh
190
-
git-x split-commit <SHA>
199
+
git-x commit split <SHA>
191
200
# Replaces SHA with N commits, one per top-level entry whose contents
192
201
# differ between SHA and its parent. Each split commit modifies one
193
202
# entry; their union reproduces the original tree exactly.
194
203
# All splits inherit SHA's author/committer/message; reword them
195
-
# individually after with `git-x reword <new-sha> -m ...`.
204
+
# individually after with `git-x commit reword <new-sha> -m ...`.
196
205
```
197
206
198
-
Combined recipe — the agent committed everything bundled, you want a
199
-
focused series:
207
+
**Squash** — collapse a range of commits into one:
200
208
201
209
```sh
202
-
git-x split-commit <bundled-sha>
203
-
git log --oneline -n 5 # see the new chain
204
-
git-x reword <split1> -m "irmin: add foo"
205
-
git-x reword <split2> -m "monopam: bump dep"
206
-
# ... etc.
210
+
git-x commit squash <sha1> <sha2> <sha3> -m "feat: combined change"
211
+
# SHAs can be given in any order; the tool topo-sorts them. The squashed
212
+
# commit keeps the newest commit's tree, author, and committer.
213
+
# Without -m, messages are joined by blank lines in ancestor-first order.
214
+
# If the SHAs aren't a parent-child chain, intervening commits are
215
+
# replayed via in-memory 3-way merge; a conflict aborts the squash.
216
+
# Refuses merge commits and commits not reachable from --ref.
217
+
```
218
+
219
+
**Sort** — stable-reorder `(BASE, head]` to cluster same-key commits:
220
+
221
+
```sh
222
+
# cluster by top-level directory (great for monorepo PR tidying)
223
+
git-x commit sort <base-sha> --by-dir
224
+
225
+
# cluster by conventional-commits prefix (feat:, fix:, docs:, ...)
226
+
git-x commit sort <base-sha> --by-prefix
227
+
228
+
# cluster by author (co-authored series cleanup)
229
+
git-x commit sort <base-sha> --by-author
230
+
231
+
# cluster by trailer value
232
+
git-x commit sort <base-sha> --by-trailer Co-Authored-By
207
233
```
208
234
209
-
All four `git-x` subcommands are concurrency-safe: the working tree,
210
-
index, and HEAD are not touched. Other agents editing files in this
211
-
checkout are unaffected.
235
+
Sort is stable: within a cluster, original order is preserved. The
236
+
reordered commits are replayed via in-memory 3-way merge; a conflict
237
+
aborts cleanly without touching the ODB or ref.
238
+
239
+
**Tidy pipeline — `split` → `sort` → `squash`:**
240
+
241
+
The three compose into a disciplined cleanup for a messy work branch
242
+
that touches many monorepo packages:
243
+
244
+
```sh
245
+
# 1. un-bundle any commits that touched multiple packages
246
+
for sha in $(git log --format=%H base..feature); do
247
+
git-x commit split $sha 2>/dev/null || true
248
+
done
249
+
250
+
# 2. cluster same-directory commits adjacent
251
+
git-x commit sort $base --by-dir --ref refs/heads/feature
252
+
253
+
# 3. fold each cluster into one atomic commit per package
254
+
# (pass each cluster's SHAs to a single squash call)
255
+
git-x commit squash <pkg1-shas...> -m "pkg1: unified change" \
256
+
--ref refs/heads/feature
257
+
258
+
# then reword each squashed commit to describe the *why* properly
259
+
git-x commit reword <squashed> -m "..."
260
+
```
261
+
262
+
All five subcommands are concurrency-safe: the working tree, index, and
263
+
HEAD are not touched. Other agents editing files in this checkout are
264
+
unaffected.
212
265
213
266
### W1. Reword a commit (no checkout)
214
267
···
253
306
254
307
### W3. Reorder commits (no checkout)
255
308
256
-
Move `<late-sha>` to just after `<base>`:
309
+
For cluster-based reorders (the common monorepo case: group commits
310
+
by directory / conventional-commits prefix / author / trailer), use
311
+
`git-x commit sort` — see W0b. The tool picks a stable total order from
312
+
the axis, replays in-memory, and atomically swings the ref.
313
+
314
+
For an arbitrary hand-crafted reorder that doesn't fit a clustering axis,
315
+
the plumbing dance is:
257
316
258
317
```sh
318
+
# move $late-sha to just after $base:
259
319
# replay $late-sha onto $base (it becomes the first commit after $base)
260
320
moved=$(git replay --onto "$base" "$late_sha"^ "$late_sha" \
261
321
| awk '{print $2}')
···
271
331
# `feature`.
272
332
```
273
333
274
-
Reordering is the most fiddly case in plumbing. If your branch
275
-
has more than ~5 commits and you need a non-trivial reorder,
276
-
W7 (worktree fallback) is often clearer.
334
+
Hand-crafted reorders are the most fiddly case in plumbing. If your
335
+
branch has more than ~5 commits and `commit sort` doesn't fit the shape
336
+
you need, W7 (worktree fallback) is often clearer.
337
+
338
+
### W4. Squash commits into one (no checkout)
339
+
340
+
For any fold of a contiguous range — a fixup into its target, several
341
+
exploratory commits into one, or the final step of the split→sort→squash
342
+
pipeline — use `git-x commit squash`:
277
343
278
-
### W4. Squash a fixup into its target (no checkout)
344
+
```sh
345
+
# fold a fixup into its target (any order; topo-sorted internally)
346
+
git-x commit squash <target-sha> <fixup-sha> --ref refs/heads/feature
347
+
348
+
# fold a three-commit range into one, with a unified message
349
+
git-x commit squash <sha1> <sha2> <sha3> \
350
+
-m "feat: coherent description of the merged change" \
351
+
--ref refs/heads/feature
352
+
```
353
+
354
+
The squashed commit inherits the newest commit's tree, author, and
355
+
committer. If the SHAs aren't a parent-child chain, intervening commits
356
+
are replayed via in-memory 3-way merge; a conflict aborts without
357
+
touching the ODB or the ref.
279
358
280
-
`<fixup-sha>` should fold into `<target-sha>`:
359
+
For the plumbing-only form (when you want full control over the
360
+
resulting tree / author / message), the classic dance still works:
281
361
282
362
```sh
283
363
# 1. compute the merged tree: target's parent state + (target → fixup) diff
284
364
merged_tree=$(git merge-tree --write-tree \
285
365
"$target"^ "$target" "$fixup")
286
366
287
-
# 2. build a new "target" commit with that tree, keeping target's
288
-
# metadata
367
+
# 2. build a new "target" commit with that tree, keeping target's metadata
289
368
author_env=$(git log -1 --format='GIT_AUTHOR_NAME=%an
290
369
GIT_AUTHOR_EMAIL=%ae
291
370
GIT_AUTHOR_DATE=%aI' "$target")
···
294
373
git commit-tree "$merged_tree" -p "$target"^ -m "$msg")
295
374
296
375
# 3. replay the rest of the branch (excluding the fixup) onto new_target
297
-
# First, drop the fixup if it's in the chain after target:
298
376
git replay --onto "$new_target" "$target" feature \
299
377
| grep -v "$fixup" \
300
378
| git update-ref --stdin
301
379
```
302
380
303
-
(Note: dropping a single commit from the replay output requires
304
-
care; for many fixups, a worktree-based `git rebase --autosquash`
305
-
in W7 is more reliable.)
381
+
Prefer `git-x commit squash` unless you need the extra control — the
382
+
plumbing form's `grep -v` step is fragile when multiple fixups share
383
+
short SHAs.
306
384
307
385
### W5. Verify the rewrite (no checkout)
308
386
···
352
430
Object writes are content-addressed and idempotent. `write_ref` is the
353
431
atomic ref update. Neither touches the working tree.
354
432
355
-
For path-glob filtering (the `git-x filter-paths` use case), the
356
-
algorithm is implemented as `Git.Filter.refs`:
433
+
For path-glob filtering (the `git-x tree drop` use case), the algorithm
434
+
is implemented as `Git.Filter.refs`:
357
435
358
436
```ocaml
359
437
let pred = Git.Filter.glob [ "*.cmi"; "*.bak" ] in
···
363
441
Fmt.pr "%a@." Git.Filter.pp_stats stats
364
442
```
365
443
366
-
Use this directly when the rewrite is part of a larger OCaml workflow
444
+
For single-commit rewrites (drop, reword, split, squash, sort), the
445
+
algorithms live in `Git.Rewrite`:
446
+
447
+
```ocaml
448
+
(* the ocaml-git equivalents of git-x commit <verb> *)
449
+
Git.Rewrite.reword_commit repo ~commit ~message ~ref_name
450
+
Git.Rewrite.drop_commit repo ~commit ~ref_name
451
+
Git.Rewrite.split_commit repo ~commit ~ref_name
452
+
Git.Rewrite.squash_commits repo ~commits ?message ~ref_name ()
453
+
Git.Rewrite.sort_commits repo ~base ~axis ~ref_name ()
454
+
```
455
+
456
+
Use these directly when the rewrite is part of a larger OCaml workflow
367
457
(e.g. a custom monorepo tool). For one-shot operations from the shell,
368
-
use the `git-x filter-paths` CLI in W0.
458
+
use the `git-x` CLI subcommands in W0 / W0b.
369
459
370
460
### W7. Fallback — rewrite in a dedicated worktree
371
461
···
485
575
Need to rewrite history.
486
576
├── Shared branch (main, release)? STOP. Branch off and rewrite there.
487
577
├── Other agents active in this checkout?
488
-
│ └── Yes: every workflow below MUST be no-checkout (W1-W6) or
578
+
│ └── Yes: every workflow below MUST be no-checkout (W0-W6) or
489
579
│ confined to a worktree (W7). Do not run rebase/reset
490
580
│ in this checkout.
491
581
│
492
-
├── What's the operation?
493
-
│ ├── Drop path globs (cmi, bak, dirs) → W0 (git-x filter-paths)
494
-
│ ├── Reword → W1 (commit-tree + replay + update-ref)
495
-
│ ├── Drop a commit → W2 (git replay --onto)
496
-
│ ├── Reorder → W3 or W7 (W3 fiddly; worktree often clearer)
497
-
│ ├── Squash a fixup → W4 or W7 (W4 fiddly for many; W7 simpler)
498
-
│ ├── Reorganize messy branch → W7 (reset + replay in worktree)
499
-
│ ├── OCaml-native → W6 (Git.Repository / Git.Filter API)
500
-
│ └── Verify result → W5 (range-diff + tree equality)
582
+
├── What's the operation? First choice Fallback
583
+
│ ├── Drop path globs (cmi, bak, dirs) W0 (git-x tree drop) --
584
+
│ ├── Reword a commit W0b (git-x commit reword) W1 (plumbing)
585
+
│ ├── Drop a commit W0b (git-x commit drop) W2 (git replay --onto)
586
+
│ ├── Split a bundled commit W0b (git-x commit split) --
587
+
│ ├── Reorder by cluster (dir/prefix/-) W0b (git-x commit sort) W3 (plumbing) / W7
588
+
│ ├── Squash a fixup or range W0b (git-x commit squash) W4 (plumbing) / W7
589
+
│ ├── Tidy messy branch (many packages) W0b (split -> sort -> squash) W7 (reset + replay)
590
+
│ ├── Arbitrary hand-crafted reorder W3 or W7 --
591
+
│ ├── OCaml-native (larger tool) W6 (Git.Rewrite / Git.Filter) --
592
+
│ └── Verify result W5 (range-diff + tree equality) --
501
593
│
502
594
└── Safety: backup branch + range-diff + --force-with-lease.
503
595
```
+151
-17
ocaml-claude-skills/plugins/monopam/skills/ocaml-encodings/SKILL.md
+151
-17
ocaml-claude-skills/plugins/monopam/skills/ocaml-encodings/SKILL.md
···
735
735
type t (* abstract *)
736
736
```
737
737
738
-
## Errors — `Loc.Error.kind`
738
+
## Errors — `Foo.Error`, a facade over `Loc.Error`
739
+
740
+
`ocaml-loc` provides the canonical error machinery. Every encoding
741
+
library ships an `Error` submodule (`foo/lib/error.ml` +
742
+
`error.mli`) that is a **facade** over `Loc.Error` — not a
743
+
competing error hierarchy. The facade has four jobs:
739
744
740
-
`ocaml-loc` provides the canonical error machinery. `Loc.Error.kind` is an
741
-
extensible variant — each format adds typed constructors and registers a
742
-
printer.
745
+
1. **Extend `Loc.Error.kind`** with typed constructors for the
746
+
format's recurring shape errors.
747
+
2. **Register printers at module-init time** so
748
+
`Loc.Error.kind_to_string` is total across extensions.
749
+
3. **Re-export the `Loc.Error` surface** (types and verbs) so
750
+
`Foo.Error.xxx` is the single place callers look.
751
+
4. **Add named raising helpers** for the format's recurring error
752
+
shapes, so decoders read `Error.sort meta ~exp ~fnd` instead of
753
+
ad-hoc `failf` strings.
743
754
744
755
```ocaml
756
+
(* foo/lib/error.ml *)
757
+
module Sort = Core.Sort
758
+
759
+
(* 1 — alias re-opens the extensible variant under this module's name *)
760
+
type kind = Loc.Error.kind = ..
761
+
762
+
(* 2 — typed constructors for this format *)
745
763
type Loc.Error.kind +=
746
-
| Sort_mismatch of { expected : Sort.t; found : Sort.t }
747
-
| Missing_member of string
748
-
| Duplicate_key of string
749
-
| Unexpected_character of char
764
+
| Sort_mismatch of { exp : Sort.t; fnd : Sort.t }
765
+
| Kinded_sort_mismatch of { exp : string; fnd : Sort.t }
750
766
767
+
(* 3 — printers registered once, at module init *)
751
768
let () =
752
769
Loc.Error.register_kind_printer @@ function
753
-
| Sort_mismatch { expected; found } ->
754
-
Some (fun ppf -> Fmt.pf ppf "expected %a, found %a"
755
-
Sort.pp expected Sort.pp found)
756
-
| Missing_member n ->
757
-
Some (fun ppf -> Fmt.pf ppf "missing member %S" n)
770
+
| Sort_mismatch { exp; fnd } ->
771
+
Some (fun ppf -> Fmt.pf ppf "Expected %a but found %a"
772
+
Sort.pp exp Sort.pp fnd)
773
+
| Kinded_sort_mismatch { exp; fnd } ->
774
+
Some (fun ppf -> Fmt.pf ppf "Expected %a but found %a"
775
+
Fmt.code exp Sort.pp fnd)
758
776
| _ -> None
777
+
778
+
(* 4 — re-exports: thin aliases, not wrappers *)
779
+
type t = Loc.Error.t = { ctx : Loc.Context.t; meta : Loc.Meta.t; kind : kind }
780
+
let v = Loc.Error.v
781
+
let msg = Loc.Error.msg
782
+
let raise = Loc.Error.raise
783
+
let fail = Loc.Error.fail
784
+
let failf = Loc.Error.failf
785
+
let push_array = Loc.Error.push_array
786
+
let push_object = Loc.Error.push_object
787
+
let pp = Loc.Error.pp
788
+
let to_string = Loc.Error.to_string
789
+
790
+
(* 5 — named helpers for recurring shapes *)
791
+
let sort meta ~exp ~fnd =
792
+
raise ~ctx:Loc.Context.empty ~meta (Sort_mismatch { exp; fnd })
793
+
let kinded_sort meta ~exp ~fnd =
794
+
raise ~ctx:Loc.Context.empty ~meta (Kinded_sort_mismatch { exp; fnd })
795
+
let missing_mems meta ~kinded_sort ~exp ~fnd = ...
796
+
let unexpected_mems meta ~kinded_sort ~exp ~fnd = ...
797
+
let index_out_of_range meta ~n ~len = ...
798
+
let number_range meta ~kind n = ...
759
799
```
760
800
801
+
The `type kind = Loc.Error.kind = ..` alias is the pivot: it re-opens
802
+
the extensible variant under a local name so users read `Foo.Error.kind`
803
+
but the underlying type is shared with every other format. Structural
804
+
aliases on `t` mean destructuring works against either module.
805
+
806
+
### Re-export under `Foo.Error` in the top-level `.mli`
807
+
808
+
```ocaml
809
+
(* foo.mli *)
810
+
module Error : sig
811
+
type kind = Loc.Error.kind = ..
812
+
type t = Loc.Error.t = { ctx : Context.t; meta : Meta.t; kind : kind }
813
+
814
+
val v : ctx:Context.t -> meta:Meta.t -> kind -> t
815
+
val raise : ctx:Context.t -> meta:Meta.t -> kind -> 'a
816
+
val fail : Meta.t -> string -> 'a
817
+
val failf : Meta.t -> (..., Format.formatter, unit, 'b) format4 -> 'a
818
+
val pp : t Fmt.t
819
+
820
+
(** {1 Typed helpers} *)
821
+
val sort : Meta.t -> exp:Sort.t -> fnd:Sort.t -> 'a
822
+
val kinded_sort : Meta.t -> exp:string -> fnd:Sort.t -> 'a
823
+
val missing_mems :
824
+
Meta.t -> kinded_sort:string -> exp:string list -> fnd:string list -> 'a
825
+
(* ... rest of the helper menu *)
826
+
end
827
+
828
+
exception Error of Error.t
829
+
(** Alias for [Loc.Error.Error]; exposed here so callers can [match]
830
+
without importing [Loc]. *)
831
+
```
832
+
833
+
### Recommended helper menu
834
+
835
+
Every format hits the same categories. A decoder written against this
836
+
vocabulary stays readable; one written against raw `failf` does not.
837
+
838
+
| Category | Helpers |
839
+
|---|---|
840
+
| Sort / shape mismatch | `sort`, `kinded_sort`, `expected` |
841
+
| Object members | `missing_mems`, `unexpected_mems`, `unexpected_case_tag` |
842
+
| Array / index | `index_out_of_range` |
843
+
| Number / integer range | `number_range`, `integer_range`, `parse_string_number` |
844
+
| Decoding direction | `no_decoder`, `decode_todo` |
845
+
| Encoding direction | `no_encoder`, `encode_todo` |
846
+
| Generic wrapper | `for'` |
847
+
848
+
`sort` / `kinded_sort` are mandatory — every format has a shape
849
+
mismatch. The rest are added as the decoder encounters each category.
850
+
Do not invent synonyms (`wrong_member`, `bad_key`) when the menu
851
+
already has the shape; decoder call-sites across formats should read
852
+
the same.
853
+
854
+
### Anti-pattern — sealed `type kind` + own exception
855
+
856
+
Do NOT model errors as a closed ADT with its own exception:
857
+
858
+
```ocaml
859
+
(* BAD *)
860
+
type kind =
861
+
| Lexer of lexer_error
862
+
| Number of number_error
863
+
| Semantic of semantic_error
864
+
| Syntax of syntax_error
865
+
866
+
type t = { kind : kind; location : location option }
867
+
exception Error of t
868
+
```
869
+
870
+
This duplicates `Loc.Error` (two exception types users must catch,
871
+
two context structures, two printer pipelines), forecloses third-party
872
+
extensions (downstream code cannot add a new error kind without
873
+
patching `foo/lib/error.ml`), and invents a parallel `location`
874
+
record instead of reusing `Loc.Meta.t` + `Loc.Context.t`. Every
875
+
format eventually wants a domain-specific error from a validation
876
+
or schema layer; the extensible `Loc.Error.kind` accommodates that,
877
+
a sealed ADT does not.
878
+
879
+
### Invariants
880
+
761
881
- Errors use `Loc.Error.t` and `Loc.Error.Error` — the shared
762
882
result type and shared exception, one pair across every format.
763
883
- Return `(_, Loc.Error.t) result`; users who want a string do
764
884
`Result.map_error Loc.Error.to_string`.
765
885
- `Loc.Context.push_array` / `push_object` chain during parsing so
766
886
errors report `users[0].email` paths for free.
887
+
- Never catch and re-raise `Loc.Error.Error` just to reshape its
888
+
kind. If a call site needs a different error label, raise the
889
+
right typed kind at the source.
890
+
891
+
Reference: [ocaml-json/lib/error.ml](https://github.com/samoht/ocaml-json/blob/main/lib/error.ml)
892
+
is the worked exemplar of this pattern.
767
893
768
894
### `Loc.Context.t` lives at the top of `Loc`
769
895
···
905
1031
codec.ml + codec.mli # codec GADT, combinators, Codec.skip
906
1032
cursor.ml + cursor.mli # zipper over Value.t (of_value / of_reader)
907
1033
stream.ml + stream.mli # (optional) iter/fold helpers, transform
908
-
error.ml + error.mli # Loc.Error.kind extension + printer registration
1034
+
error.ml + error.mli # Foo.Error facade: Loc.Error.kind extension,
1035
+
# printer registration, Loc.Error re-exports,
1036
+
# typed helpers (see Errors section)
909
1037
foo.ml + foo.mli # top-level: type aliases, IO entry points, re-exports
910
1038
dune # (library (name foo) ...)
911
1039
```
···
1184
1312
- [ ] Six top-level verbs: `of_string` / `to_string` / `of_reader` /
1185
1313
`to_writer` / `decode` / `encode`.
1186
1314
- [ ] `_exn` twin for each `of_*` and `decode`. No `'` variants.
1187
-
- [ ] Errors via `Loc.Error.t`; format-specific kinds extend
1188
-
`Loc.Error.kind` with typed constructors and a registered printer.
1189
-
- [ ] `_exn` raises `Loc.Error.Error` (shared). No per-library exception.
1315
+
- [ ] `Foo.Error` is a facade over `Loc.Error`: extends
1316
+
`Loc.Error.kind` with typed constructors, registers printers at
1317
+
module init, re-exports `Loc.Error` verbs (`v`, `raise`, `fail`,
1318
+
`failf`, `push_array`, `push_object`, `pp`, `to_string`), and
1319
+
provides typed helpers (`sort`, `kinded_sort`, `missing_mems`,
1320
+
`unexpected_mems`, `index_out_of_range`, `number_range`,
1321
+
`no_decoder`, `decode_todo`, ...).
1322
+
- [ ] `_exn` raises `Loc.Error.Error` (shared). No per-library
1323
+
exception, no sealed `type kind` ADT.
1190
1324
- [ ] Parser uses exceptions internally; result wrapping at the boundary.
1191
1325
- [ ] UTF-8 validated streaming via `uutf`; normalization only via `uunf`
1192
1326
where the spec requires, streaming.
+1
-1
ocaml-claude/lib/claude.ml
+1
-1
ocaml-claude/lib/claude.ml
+10
-10
ocaml-claude/lib/claude.mli
+10
-10
ocaml-claude/lib/claude.mli
···
149
149
150
150
{1 Error Handling}
151
151
152
-
The library uses a structured exception type {!Err.E} for all errors:
152
+
The library uses a structured exception type {!Error.E} for all errors:
153
153
154
154
{[
155
155
try Claude.Client.query client "Hello"
156
-
with Claude.Err.E err ->
157
-
Printf.eprintf "Error: %s\n" (Claude.Err.to_string err)
156
+
with Claude.Error.E err ->
157
+
Printf.eprintf "Error: %s\n" (Claude.Error.to_string err)
158
158
]}
159
159
160
160
Error types include:
161
-
- {!Err.Cli_not_found}: Claude CLI not found
162
-
- {!Err.Process_error}: Process execution failure
163
-
- {!Err.Protocol_error}: JSON/protocol parsing error
164
-
- {!Err.Timeout}: Operation timed out
165
-
- {!Err.Permission_denied}: Tool permission denied
166
-
- {!Err.Hook_error}: Hook callback error
161
+
- {!Error.Cli_not_found}: Claude CLI not found
162
+
- {!Error.Process_error}: Process execution failure
163
+
- {!Error.Protocol_error}: JSON/protocol parsing error
164
+
- {!Error.Timeout}: Operation timed out
165
+
- {!Error.Permission_denied}: Tool permission denied
166
+
- {!Error.Hook_error}: Hook callback error
167
167
168
168
{1 Logging}
169
169
···
177
177
178
178
(** {1 Core Modules} *)
179
179
180
-
module Err = Err
180
+
module Error = Error
181
181
(** Error handling with structured exception type. *)
182
182
183
183
module Client = Client
+4
-4
ocaml-claude/lib/client.ml
+4
-4
ocaml-claude/lib/client.ml
···
8
8
module Log = (val Logs.src_log src : Logs.LOG)
9
9
10
10
let encode_or_raise ~msg codec v =
11
-
Json.encode codec v |> Result.map_error Json.Error.to_string |> Err.ok ~msg
11
+
Json.encode codec v |> Result.map_error Json.Error.to_string |> Error.ok ~msg
12
12
13
13
(** Control response builders using Control codecs *)
14
14
module Control_response = struct
···
44
44
(fun m ->
45
45
Json.encode json m
46
46
|> Result.map_error Json.Error.to_string
47
-
|> Err.ok ~msg:"Hook_matcher_wire.encode: ")
47
+
|> Error.ok ~msg:"Hook_matcher_wire.encode: ")
48
48
matchers
49
49
|> Json.list
50
50
end
···
456
456
t.permission_log |> Option.map ( ! ) |> Option.value ~default:[]
457
457
458
458
let decode_or_raise ~msg codec v =
459
-
Json.decode codec v |> Result.map_error Json.Error.to_string |> Err.ok' ~msg
459
+
Json.decode codec v |> Result.map_error Json.Error.to_string |> Error.ok' ~msg
460
460
461
461
let decode_control_response response_json =
462
462
let response_field_codec =
···
541
541
let response_data =
542
542
send_control_request t ~request_id request
543
543
|> Option.to_result ~none:"No response data from get_server_info request"
544
-
|> Err.ok ~msg:""
544
+
|> Error.ok ~msg:""
545
545
in
546
546
let server_info =
547
547
decode_or_raise ~msg:"Failed to decode server info: "
+1
-1
ocaml-claude/test/test.ml
+1
-1
ocaml-claude/test/test.ml
-173
ocaml-claude/test/test_err.ml
-173
ocaml-claude/test/test_err.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Tests for Err module: error formatting, raisers, and result helpers. *)
7
-
8
-
let test_cli_not_found_format () =
9
-
let err = Claude.Err.Cli_not_found "claude not in PATH" in
10
-
Alcotest.(check string)
11
-
"format" "CLI not found: claude not in PATH" (Claude.Err.to_string err)
12
-
13
-
let test_process_error_format () =
14
-
let err = Claude.Err.Process_error "exit code 1" in
15
-
Alcotest.(check string)
16
-
"format" "Process error: exit code 1" (Claude.Err.to_string err)
17
-
18
-
let test_connection_error_format () =
19
-
let err = Claude.Err.Connection_error "refused" in
20
-
Alcotest.(check string)
21
-
"format" "Connection error: refused" (Claude.Err.to_string err)
22
-
23
-
let test_protocol_error_format () =
24
-
let err = Claude.Err.Protocol_error "bad json" in
25
-
Alcotest.(check string)
26
-
"format" "Protocol error: bad json" (Claude.Err.to_string err)
27
-
28
-
let test_timeout_format () =
29
-
let err = Claude.Err.Timeout "30s elapsed" in
30
-
Alcotest.(check string)
31
-
"format" "Timeout: 30s elapsed" (Claude.Err.to_string err)
32
-
33
-
let test_permission_denied_format () =
34
-
let err =
35
-
Claude.Err.Permission_denied { tool_name = "Bash"; message = "not allowed" }
36
-
in
37
-
Alcotest.(check string)
38
-
"format" "Permission denied for tool 'Bash': not allowed"
39
-
(Claude.Err.to_string err)
40
-
41
-
let test_hook_error_format () =
42
-
let err =
43
-
Claude.Err.Hook_error { callback_id = "cb-1"; message = "hook failed" }
44
-
in
45
-
Alcotest.(check string)
46
-
"format" "Hook error (callback_id=cb-1): hook failed"
47
-
(Claude.Err.to_string err)
48
-
49
-
let test_control_error_format () =
50
-
let err =
51
-
Claude.Err.Control_error { request_id = "req-42"; message = "invalid" }
52
-
in
53
-
Alcotest.(check string)
54
-
"format" "Control error (request_id=req-42): invalid"
55
-
(Claude.Err.to_string err)
56
-
57
-
let test_raise_cli_not_found () =
58
-
match Claude.Err.cli_not_found "missing" with
59
-
| exception Claude.Err.E (Claude.Err.Cli_not_found "missing") -> ()
60
-
| exception _ -> Alcotest.fail "Wrong exception type"
61
-
| _ -> Alcotest.fail "Expected exception"
62
-
63
-
let test_raise_process_error () =
64
-
match Claude.Err.process_error "crash" with
65
-
| exception Claude.Err.E (Claude.Err.Process_error "crash") -> ()
66
-
| exception _ -> Alcotest.fail "Wrong exception type"
67
-
| _ -> Alcotest.fail "Expected exception"
68
-
69
-
let test_raise_connection_error () =
70
-
match Claude.Err.connection_error "reset" with
71
-
| exception Claude.Err.E (Claude.Err.Connection_error "reset") -> ()
72
-
| exception _ -> Alcotest.fail "Wrong exception type"
73
-
| _ -> Alcotest.fail "Expected exception"
74
-
75
-
let test_raise_protocol_error () =
76
-
match Claude.Err.protocol_error "malformed" with
77
-
| exception Claude.Err.E (Claude.Err.Protocol_error "malformed") -> ()
78
-
| exception _ -> Alcotest.fail "Wrong exception type"
79
-
| _ -> Alcotest.fail "Expected exception"
80
-
81
-
let test_raise_timeout () =
82
-
match Claude.Err.timeout "expired" with
83
-
| exception Claude.Err.E (Claude.Err.Timeout "expired") -> ()
84
-
| exception _ -> Alcotest.fail "Wrong exception type"
85
-
| _ -> Alcotest.fail "Expected exception"
86
-
87
-
let test_raise_permission_denied () =
88
-
match Claude.Err.permission_denied ~tool_name:"Edit" ~message:"blocked" with
89
-
| exception
90
-
Claude.Err.E
91
-
(Claude.Err.Permission_denied
92
-
{ tool_name = "Edit"; message = "blocked" }) ->
93
-
()
94
-
| exception _ -> Alcotest.fail "Wrong exception type"
95
-
| _ -> Alcotest.fail "Expected exception"
96
-
97
-
let test_raise_hook_error () =
98
-
match Claude.Err.hook_error ~callback_id:"cb-x" ~message:"fail" with
99
-
| exception
100
-
Claude.Err.E
101
-
(Claude.Err.Hook_error { callback_id = "cb-x"; message = "fail" }) ->
102
-
()
103
-
| exception _ -> Alcotest.fail "Wrong exception type"
104
-
| _ -> Alcotest.fail "Expected exception"
105
-
106
-
let test_raise_control_error () =
107
-
match Claude.Err.control_error ~request_id:"req-1" ~message:"bad" with
108
-
| exception
109
-
Claude.Err.E
110
-
(Claude.Err.Control_error { request_id = "req-1"; message = "bad" }) ->
111
-
()
112
-
| exception _ -> Alcotest.fail "Wrong exception type"
113
-
| _ -> Alcotest.fail "Expected exception"
114
-
115
-
let test_ok_success () =
116
-
let v = Claude.Err.ok ~msg:"test: " (Ok 42) in
117
-
Alcotest.(check int) "ok value" 42 v
118
-
119
-
let test_ok_error () =
120
-
match Claude.Err.ok ~msg:"prefix: " (Error "reason") with
121
-
| exception Claude.Err.E (Claude.Err.Protocol_error msg) ->
122
-
Alcotest.(check bool) "contains prefix" true (String.length msg > 0)
123
-
| exception _ -> Alcotest.fail "Wrong exception type"
124
-
| _ -> Alcotest.fail "Expected exception"
125
-
126
-
let test_ok'_success () =
127
-
let v = Claude.Err.ok' ~msg:"test: " (Ok "hello") in
128
-
Alcotest.(check string) "ok' value" "hello" v
129
-
130
-
let test_ok'_error () =
131
-
match Claude.Err.ok' ~msg:"prefix: " (Error "reason") with
132
-
| exception Claude.Err.E (Claude.Err.Protocol_error _) -> ()
133
-
| exception _ -> Alcotest.fail "Wrong exception type"
134
-
| _ -> Alcotest.fail "Expected exception"
135
-
136
-
let test_pp_output () =
137
-
let err = Claude.Err.Timeout "10s" in
138
-
let buf = Buffer.create 32 in
139
-
let ppf = Format.formatter_of_buffer buf in
140
-
Claude.Err.pp ppf err;
141
-
Format.pp_print_flush ppf ();
142
-
Alcotest.(check string) "pp output" "Timeout: 10s" (Buffer.contents buf)
143
-
144
-
let suite =
145
-
( "err",
146
-
[
147
-
Alcotest.test_case "Cli_not_found format" `Quick test_cli_not_found_format;
148
-
Alcotest.test_case "Process_error format" `Quick test_process_error_format;
149
-
Alcotest.test_case "Connection_error format" `Quick
150
-
test_connection_error_format;
151
-
Alcotest.test_case "Protocol_error format" `Quick
152
-
test_protocol_error_format;
153
-
Alcotest.test_case "Timeout format" `Quick test_timeout_format;
154
-
Alcotest.test_case "Permission_denied format" `Quick
155
-
test_permission_denied_format;
156
-
Alcotest.test_case "Hook_error format" `Quick test_hook_error_format;
157
-
Alcotest.test_case "Control_error format" `Quick test_control_error_format;
158
-
Alcotest.test_case "raise cli_not_found" `Quick test_raise_cli_not_found;
159
-
Alcotest.test_case "raise process_error" `Quick test_raise_process_error;
160
-
Alcotest.test_case "raise connection_error" `Quick
161
-
test_raise_connection_error;
162
-
Alcotest.test_case "raise protocol_error" `Quick test_raise_protocol_error;
163
-
Alcotest.test_case "raise timeout" `Quick test_raise_timeout;
164
-
Alcotest.test_case "raise permission_denied" `Quick
165
-
test_raise_permission_denied;
166
-
Alcotest.test_case "raise hook_error" `Quick test_raise_hook_error;
167
-
Alcotest.test_case "raise control_error" `Quick test_raise_control_error;
168
-
Alcotest.test_case "ok success" `Quick test_ok_success;
169
-
Alcotest.test_case "ok error" `Quick test_ok_error;
170
-
Alcotest.test_case "ok' success" `Quick test_ok'_success;
171
-
Alcotest.test_case "ok' error" `Quick test_ok'_error;
172
-
Alcotest.test_case "pp output" `Quick test_pp_output;
173
-
] )
-2
ocaml-claude/test/test_err.mli
-2
ocaml-claude/test/test_err.mli
-1
ocaml-clcw/c/dune
-1
ocaml-clcw/c/dune
-1
ocaml-clcw/fuzz/dune
-1
ocaml-clcw/fuzz/dune
-1
ocaml-collision/fuzz/dune
-1
ocaml-collision/fuzz/dune
+4
-9
ocaml-collision/lib/collision.ml
+4
-9
ocaml-collision/lib/collision.ml
···
8
8
(* {1 Types} *)
9
9
10
10
type vec3 = Vec3.t = { x : float; y : float; z : float }
11
-
type sym2 = { a11 : float; a12 : float; a22 : float }
12
11
13
12
type encounter = {
14
13
miss_x : float;
···
395
394
396
395
type tca = { time : float; miss_distance : float; relative_velocity : float }
397
396
398
-
let tca_at_index times pos1 pos2 vel1 vel2 i d2 =
397
+
let tca_at_index times vel1 vel2 i d2 =
399
398
let d = sqrt d2 in
400
399
let dv = Vec3.length (Vec3.sub vel1.(i) vel2.(i)) in
401
400
{ time = times.(i); miss_distance = d; relative_velocity = dv }
···
421
420
min_i := i)
422
421
done;
423
422
let i = !min_i in
424
-
if i = 0 || i = n - 1 then
425
-
Some (tca_at_index times pos1 pos2 vel1 vel2 i !min_d2)
423
+
if i = 0 || i = n - 1 then Some (tca_at_index times vel1 vel2 i !min_d2)
426
424
else
427
425
(* Step 2: quadratic refinement around minimum *)
428
426
let t0 = times.(i - 1) and t1 = times.(i) and t2 = times.(i + 1) in
···
432
430
let h0 = t0 -. t1 and h2 = t2 -. t1 in
433
431
let denom = h0 *. h2 *. (h2 -. h0) in
434
432
if Float.abs denom < 1e-30 || denom = 0.0 then
435
-
Some (tca_at_index times pos1 pos2 vel1 vel2 i !min_d2)
433
+
Some (tca_at_index times vel1 vel2 i !min_d2)
436
434
else
437
435
let a = ((h2 *. (y0 -. y1)) -. (h0 *. (y2 -. y1))) /. denom in
438
436
let b =
439
437
((h0 *. h0 *. (y2 -. y1)) -. (h2 *. h2 *. (y0 -. y1))) /. denom
440
438
in
441
-
if a <= 0.0 then Some (tca_at_index times pos1 pos2 vel1 vel2 i !min_d2)
439
+
if a <= 0.0 then Some (tca_at_index times vel1 vel2 i !min_d2)
442
440
else
443
441
let dt = -.b /. (2.0 *. a) in
444
442
let t_star = Float.max t0 (Float.min t2 (t1 +. dt)) in
···
505
503
a.pc pp_risk (risk_level a) a.pc_max a.miss_distance a.relative_velocity
506
504
507
505
(* {1 Pretty-printing} *)
508
-
509
-
let pp_sym2 ppf s =
510
-
Fmt.pf ppf "| %.6e %.6e |@,| %.6e %.6e |" s.a11 s.a12 s.a12 s.a22
511
506
512
507
let pp_encounter ppf e =
513
508
Fmt.pf ppf
-4
ocaml-contact/bin/main.ml
-4
ocaml-contact/bin/main.ml
···
128
128
let s = int_of_float secs mod 60 in
129
129
Fmt.str "%dm%02ds" m s
130
130
131
-
let el_bar max_el =
132
-
let n = int_of_float (max_el /. 90.0 *. 20.0) in
133
-
String.make (max 1 n) '#'
134
-
135
131
(* ── Predict command ────────────────────────────────────────────────── *)
136
132
137
133
let predict_cmd tle_path loc alt days min_el () =
-1
ocaml-cookeio/fuzz/dune
-1
ocaml-cookeio/fuzz/dune
-1
ocaml-coordinate/fuzz/dune
-1
ocaml-coordinate/fuzz/dune
+5
-6
ocaml-coordinate/lib/coordinate.mli
+5
-6
ocaml-coordinate/lib/coordinate.mli
···
42
42
(** [gmst t] returns Greenwich Mean Sidereal Time in radians. *)
43
43
44
44
val gast : Ptime.t -> float
45
-
(** [gast t] returns Greenwich Apparent Sidereal Time in radians — GMST
46
-
plus the equation of the equinoxes (the nutation-driven correction
47
-
that accounts for the wobble of the true equinox relative to the
48
-
mean equinox). Use this when you need sidereal time aligned with
49
-
the true orientation of Earth's axis rather than the mean
50
-
orientation. *)
45
+
(** [gast t] returns Greenwich Apparent Sidereal Time in radians — GMST plus the
46
+
equation of the equinoxes (the nutation-driven correction that accounts for
47
+
the wobble of the true equinox relative to the mean equinox). Use this when
48
+
you need sidereal time aligned with the true orientation of Earth's axis
49
+
rather than the mean orientation. *)
51
50
52
51
val julian_date_of_unix : float -> float
53
52
(** [julian_date_of_unix t] converts Unix timestamp to Julian date. *)
-1
ocaml-cop1/fuzz/dune
-1
ocaml-cop1/fuzz/dune
-1
ocaml-cose/fuzz/dune
-1
ocaml-cose/fuzz/dune
-5
ocaml-cose/test/interop/pycose/test.ml
-5
ocaml-cose/test/interop/pycose/test.ml
···
27
27
in
28
28
Char.chr ((digit hex.[i * 2] lsl 4) lor digit hex.[(i * 2) + 1]))
29
29
30
-
let string_to_hex s =
31
-
let buf = Buffer.create (String.length s * 2) in
32
-
String.iter (fun c -> Buffer.add_string buf (Fmt.str "%02x" (Char.code c))) s;
33
-
Buffer.contents buf
34
-
35
30
(* {1 Header traces} *)
36
31
37
32
type header_row = {
-1
ocaml-cpio/fuzz/dune
-1
ocaml-cpio/fuzz/dune
-13
ocaml-cpio/test/test_cpio.ml
-13
ocaml-cpio/test/test_cpio.ml
···
11
11
3. Property tests: covered by fuzz/fuzz_cpio.ml
12
12
*)
13
13
14
-
let entry =
15
-
Alcotest.testable
16
-
(fun ppf e ->
17
-
Fmt.pf ppf "{name=%S; mode=0o%o; size=%d}" e.Cpio.header.name
18
-
e.Cpio.header.mode
19
-
(String.length e.Cpio.data))
20
-
(fun a b ->
21
-
a.Cpio.header.name = b.Cpio.header.name
22
-
&& a.Cpio.header.mode = b.Cpio.header.mode
23
-
&& a.Cpio.header.uid = b.Cpio.header.uid
24
-
&& a.Cpio.header.gid = b.Cpio.header.gid
25
-
&& a.Cpio.data = b.Cpio.data)
26
-
27
14
(* Test roundtrip: single regular file *)
28
15
let test_roundtrip_regular () =
29
16
let content = "Hello, World!\n" in
-1
ocaml-crc/fuzz/dune
-1
ocaml-crc/fuzz/dune
+3
-10
ocaml-crow/lib/afl.ml
+3
-10
ocaml-crow/lib/afl.ml
···
10
10
type eio_process = P : _ Eio.Process.t -> eio_process
11
11
12
12
type env = {
13
-
sw : Eio.Switch.t;
14
13
spawn_proc : string list -> eio_process;
15
14
fs : Eio.Fs.dir_ty Eio.Path.t;
16
15
build_dir : string;
···
18
17
19
18
let env ~sw ~process_mgr ~fs ~build_dir =
20
19
let spawn_proc args = P (Eio.Process.spawn ~sw process_mgr args) in
21
-
{ sw; spawn_proc; fs :> Eio.Fs.dir_ty Eio.Path.t; build_dir }
20
+
{ spawn_proc; fs :> Eio.Fs.dir_ty Eio.Path.t; build_dir }
22
21
23
-
type process = {
24
-
proc : eio_process;
25
-
pid : int;
26
-
target : Target.t;
27
-
mode : [ `Main | `Secondary of int ];
28
-
started : float;
29
-
}
22
+
type process = { proc : eio_process; pid : int }
30
23
31
24
let mode_to_string = function
32
25
| `Main -> "main"
···
92
85
let pid = Eio.Process.pid proc in
93
86
Log.debug (fun f ->
94
87
f "Started AFL process %d for %s" pid (Target.name target));
95
-
{ proc = P proc; pid; target; mode; started = Unix.gettimeofday () }
88
+
{ proc = P proc; pid }
96
89
97
90
let pid p = p.pid
98
91
-1
ocaml-crypto/bench/dune
-1
ocaml-crypto/bench/dune
-1
ocaml-crypto/fuzz/dune
-1
ocaml-crypto/fuzz/dune
+1
-9
ocaml-crypto/test/ec/wycheproof/dune
+1
-9
ocaml-crypto/test/ec/wycheproof/dune
+92
-91
ocaml-crypto/test/ec/wycheproof/wycheproof.ml
+92
-91
ocaml-crypto/test/ec/wycheproof/wycheproof.ml
···
1
-
type json = Jsont.json
1
+
type json = Json.t
2
2
3
-
let pp_json ppf json =
4
-
match Jsont_bytesrw.encode_string Jsont.json json with
5
-
| Ok s -> Format.pp_print_string ppf s
6
-
| Error _ -> Format.pp_print_string ppf "<json>"
3
+
let pp_json ppf json = Format.pp_print_string ppf (Json.Value.to_string json)
7
4
8
5
type hex = string
9
6
···
21
18
22
19
let hex_jsont =
23
20
let padded s = if String.length s mod 2 = 0 then s else "0" ^ s in
24
-
Jsont.map ~kind:"hex"
21
+
Json.Codec.map ~kind:"hex"
25
22
~dec:(fun s -> hex_of_string (padded s))
26
23
~enc:(fun h -> Ohex.encode h)
27
-
Jsont.string
24
+
Json.Codec.string
28
25
29
26
type test_result = Valid | Acceptable | Invalid
30
27
···
39
36
| Invalid -> "Invalid"
40
37
41
38
let test_result_jsont =
42
-
Jsont.map ~kind:"test_result"
39
+
Json.Codec.map ~kind:"test_result"
43
40
~dec:(function
44
41
| "valid" -> Valid
45
42
| "acceptable" -> Acceptable
···
47
44
| _ -> failwith "test_result: expected valid, acceptable, or invalid")
48
45
~enc:(function
49
46
| Valid -> "valid" | Acceptable -> "acceptable" | Invalid -> "invalid")
50
-
Jsont.string
47
+
Json.Codec.string
51
48
52
49
type ecdh_test = {
53
50
tc_id : int;
···
73
70
let show_ecdh_test t = Fmt.str "%a" pp_ecdh_test t
74
71
75
72
let ecdh_test_jsont =
76
-
Jsont.Object.map ~kind:"ecdh_test"
73
+
Json.Codec.Object.map ~kind:"ecdh_test"
77
74
(fun tc_id comment curve public private_ shared result flags ->
78
75
{
79
76
tc_id;
···
85
82
result;
86
83
flags = Option.value ~default:[] flags;
87
84
})
88
-
|> Jsont.Object.mem "tcId" Jsont.int ~enc:(fun t -> t.tc_id)
89
-
|> Jsont.Object.mem "comment" Jsont.string ~enc:(fun t -> t.comment)
90
-
|> Jsont.Object.opt_mem "curve" Jsont.json ~enc:(fun t -> t.curve)
91
-
|> Jsont.Object.mem "public" hex_jsont ~enc:(fun t -> t.public)
92
-
|> Jsont.Object.mem "private" hex_jsont ~enc:(fun t -> t.private_)
93
-
|> Jsont.Object.mem "shared" hex_jsont ~enc:(fun t -> t.shared)
94
-
|> Jsont.Object.mem "result" test_result_jsont ~enc:(fun t -> t.result)
95
-
|> Jsont.Object.opt_mem "flags" (Jsont.list Jsont.string) ~enc:(fun t ->
96
-
if t.flags = [] then None else Some t.flags)
97
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
85
+
|> Json.Codec.Object.mem "tcId" Json.Codec.int ~enc:(fun t -> t.tc_id)
86
+
|> Json.Codec.Object.mem "comment" Json.Codec.string ~enc:(fun t -> t.comment)
87
+
|> Json.Codec.Object.opt_mem "curve" Json.Codec.Value.t ~enc:(fun t ->
88
+
t.curve)
89
+
|> Json.Codec.Object.mem "public" hex_jsont ~enc:(fun t -> t.public)
90
+
|> Json.Codec.Object.mem "private" hex_jsont ~enc:(fun t -> t.private_)
91
+
|> Json.Codec.Object.mem "shared" hex_jsont ~enc:(fun t -> t.shared)
92
+
|> Json.Codec.Object.mem "result" test_result_jsont ~enc:(fun t -> t.result)
93
+
|> Json.Codec.Object.opt_mem "flags" (Json.Codec.list Json.Codec.string)
94
+
~enc:(fun t -> if t.flags = [] then None else Some t.flags)
95
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
98
96
99
97
let has_ignored_flag test ~ignored_flags =
100
98
List.exists
···
119
117
let show_ecdh_test_group t = Fmt.str "%a" pp_ecdh_test_group t
120
118
121
119
let ecdh_test_group_jsont =
122
-
Jsont.Object.map ~kind:"ecdh_test_group" (fun curve tests encoding type_ ->
123
-
{ curve; tests; encoding; type_ })
124
-
|> Jsont.Object.mem "curve" Jsont.string ~enc:(fun t -> t.curve)
125
-
|> Jsont.Object.mem "tests" (Jsont.list ecdh_test_jsont) ~enc:(fun t ->
126
-
t.tests)
127
-
|> Jsont.Object.opt_mem "encoding" Jsont.json ~enc:(fun t -> t.encoding)
128
-
|> Jsont.Object.opt_mem "type" Jsont.json ~enc:(fun t -> t.type_)
129
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
120
+
Json.Codec.Object.map ~kind:"ecdh_test_group"
121
+
(fun curve tests encoding type_ -> { curve; tests; encoding; type_ })
122
+
|> Json.Codec.Object.mem "curve" Json.Codec.string ~enc:(fun t -> t.curve)
123
+
|> Json.Codec.Object.mem "tests" (Json.Codec.list ecdh_test_jsont)
124
+
~enc:(fun t -> t.tests)
125
+
|> Json.Codec.Object.opt_mem "encoding" Json.Codec.Value.t ~enc:(fun t ->
126
+
t.encoding)
127
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.Value.t ~enc:(fun t -> t.type_)
128
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
130
129
131
130
type ecdsa_key = {
132
131
curve : string;
···
147
146
let show_ecdsa_key t = Fmt.str "%a" pp_ecdsa_key t
148
147
149
148
let ecdsa_key_jsont =
150
-
Jsont.Object.map ~kind:"ecdsa_key"
149
+
Json.Codec.Object.map ~kind:"ecdsa_key"
151
150
(fun curve key_size type_ uncompressed wx wy ->
152
151
{ curve; key_size; type_; uncompressed; wx; wy })
153
-
|> Jsont.Object.mem "curve" Jsont.string ~enc:(fun t -> t.curve)
154
-
|> Jsont.Object.mem "keySize" Jsont.int ~enc:(fun t -> t.key_size)
155
-
|> Jsont.Object.mem "type" Jsont.json ~enc:(fun t -> t.type_)
156
-
|> Jsont.Object.mem "uncompressed" hex_jsont ~enc:(fun t -> t.uncompressed)
157
-
|> Jsont.Object.mem "wx" hex_jsont ~enc:(fun t -> t.wx)
158
-
|> Jsont.Object.mem "wy" hex_jsont ~enc:(fun t -> t.wy)
159
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
152
+
|> Json.Codec.Object.mem "curve" Json.Codec.string ~enc:(fun t -> t.curve)
153
+
|> Json.Codec.Object.mem "keySize" Json.Codec.int ~enc:(fun t -> t.key_size)
154
+
|> Json.Codec.Object.mem "type" Json.Codec.Value.t ~enc:(fun t -> t.type_)
155
+
|> Json.Codec.Object.mem "uncompressed" hex_jsont ~enc:(fun t ->
156
+
t.uncompressed)
157
+
|> Json.Codec.Object.mem "wx" hex_jsont ~enc:(fun t -> t.wx)
158
+
|> Json.Codec.Object.mem "wy" hex_jsont ~enc:(fun t -> t.wy)
159
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
160
160
161
161
type dsa_test = {
162
162
tc_id : int;
···
177
177
let show_dsa_test t = Fmt.str "%a" pp_dsa_test t
178
178
179
179
let dsa_test_jsont =
180
-
Jsont.Object.map ~kind:"dsa_test" (fun tc_id comment msg sig_ result flags ->
180
+
Json.Codec.Object.map ~kind:"dsa_test"
181
+
(fun tc_id comment msg sig_ result flags ->
181
182
{
182
183
tc_id;
183
184
comment;
···
186
187
result;
187
188
flags = Option.value ~default:[] flags;
188
189
})
189
-
|> Jsont.Object.mem "tcId" Jsont.int ~enc:(fun t -> t.tc_id)
190
-
|> Jsont.Object.mem "comment" Jsont.string ~enc:(fun t -> t.comment)
191
-
|> Jsont.Object.mem "msg" hex_jsont ~enc:(fun t -> t.msg)
192
-
|> Jsont.Object.mem "sig" hex_jsont ~enc:(fun t -> t.sig_)
193
-
|> Jsont.Object.mem "result" test_result_jsont ~enc:(fun t -> t.result)
194
-
|> Jsont.Object.opt_mem "flags" (Jsont.list Jsont.string) ~enc:(fun t ->
195
-
if t.flags = [] then None else Some t.flags)
196
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
190
+
|> Json.Codec.Object.mem "tcId" Json.Codec.int ~enc:(fun t -> t.tc_id)
191
+
|> Json.Codec.Object.mem "comment" Json.Codec.string ~enc:(fun t -> t.comment)
192
+
|> Json.Codec.Object.mem "msg" hex_jsont ~enc:(fun t -> t.msg)
193
+
|> Json.Codec.Object.mem "sig" hex_jsont ~enc:(fun t -> t.sig_)
194
+
|> Json.Codec.Object.mem "result" test_result_jsont ~enc:(fun t -> t.result)
195
+
|> Json.Codec.Object.opt_mem "flags" (Json.Codec.list Json.Codec.string)
196
+
~enc:(fun t -> if t.flags = [] then None else Some t.flags)
197
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
197
198
198
199
type ecdsa_test_group = {
199
200
key : ecdsa_key;
···
215
216
let show_ecdsa_test_group t = Fmt.str "%a" pp_ecdsa_test_group t
216
217
217
218
let ecdsa_test_group_jsont =
218
-
Jsont.Object.map ~kind:"ecdsa_test_group"
219
+
Json.Codec.Object.map ~kind:"ecdsa_test_group"
219
220
(fun key key_der key_pem sha tests type_ ->
220
221
{ key; key_der; key_pem; sha; tests; type_ })
221
-
|> Jsont.Object.mem "key" ecdsa_key_jsont ~enc:(fun t -> t.key)
222
-
|> Jsont.Object.mem "keyDer" Jsont.string ~enc:(fun t -> t.key_der)
223
-
|> Jsont.Object.mem "keyPem" Jsont.string ~enc:(fun t -> t.key_pem)
224
-
|> Jsont.Object.mem "sha" Jsont.string ~enc:(fun t -> t.sha)
225
-
|> Jsont.Object.mem "tests" (Jsont.list dsa_test_jsont) ~enc:(fun t ->
226
-
t.tests)
227
-
|> Jsont.Object.opt_mem "type" Jsont.json ~enc:(fun t -> t.type_)
228
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
222
+
|> Json.Codec.Object.mem "key" ecdsa_key_jsont ~enc:(fun t -> t.key)
223
+
|> Json.Codec.Object.mem "keyDer" Json.Codec.string ~enc:(fun t -> t.key_der)
224
+
|> Json.Codec.Object.mem "keyPem" Json.Codec.string ~enc:(fun t -> t.key_pem)
225
+
|> Json.Codec.Object.mem "sha" Json.Codec.string ~enc:(fun t -> t.sha)
226
+
|> Json.Codec.Object.mem "tests" (Json.Codec.list dsa_test_jsont)
227
+
~enc:(fun t -> t.tests)
228
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.Value.t ~enc:(fun t -> t.type_)
229
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
229
230
230
231
type eddsa_key = {
231
232
curve : string;
···
242
243
let show_eddsa_key t = Fmt.str "%a" pp_eddsa_key t
243
244
244
245
let eddsa_key_jsont =
245
-
Jsont.Object.map ~kind:"eddsa_key" (fun curve key_size pk sk type_ ->
246
+
Json.Codec.Object.map ~kind:"eddsa_key" (fun curve key_size pk sk type_ ->
246
247
{ curve; key_size; pk; sk; type_ })
247
-
|> Jsont.Object.mem "curve" Jsont.string ~enc:(fun t -> t.curve)
248
-
|> Jsont.Object.mem "keySize" Jsont.int ~enc:(fun t -> t.key_size)
249
-
|> Jsont.Object.mem "pk" hex_jsont ~enc:(fun t -> t.pk)
250
-
|> Jsont.Object.mem "sk" hex_jsont ~enc:(fun t -> t.sk)
251
-
|> Jsont.Object.mem "type" Jsont.json ~enc:(fun t -> t.type_)
252
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
248
+
|> Json.Codec.Object.mem "curve" Json.Codec.string ~enc:(fun t -> t.curve)
249
+
|> Json.Codec.Object.mem "keySize" Json.Codec.int ~enc:(fun t -> t.key_size)
250
+
|> Json.Codec.Object.mem "pk" hex_jsont ~enc:(fun t -> t.pk)
251
+
|> Json.Codec.Object.mem "sk" hex_jsont ~enc:(fun t -> t.sk)
252
+
|> Json.Codec.Object.mem "type" Json.Codec.Value.t ~enc:(fun t -> t.type_)
253
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
253
254
254
255
type eddsa_test_group = {
255
256
jwk : json;
···
270
271
let show_eddsa_test_group t = Fmt.str "%a" pp_eddsa_test_group t
271
272
272
273
let eddsa_test_group_jsont =
273
-
Jsont.Object.map ~kind:"eddsa_test_group"
274
+
Json.Codec.Object.map ~kind:"eddsa_test_group"
274
275
(fun jwk key key_der key_pem type_ tests ->
275
276
{ jwk; key; key_der; key_pem; type_; tests })
276
-
|> Jsont.Object.mem "jwk" Jsont.json ~enc:(fun t -> t.jwk)
277
-
|> Jsont.Object.mem "key" eddsa_key_jsont ~enc:(fun t -> t.key)
278
-
|> Jsont.Object.mem "keyDer" Jsont.string ~enc:(fun t -> t.key_der)
279
-
|> Jsont.Object.mem "keyPem" Jsont.string ~enc:(fun t -> t.key_pem)
280
-
|> Jsont.Object.mem "type" Jsont.json ~enc:(fun t -> t.type_)
281
-
|> Jsont.Object.mem "tests" (Jsont.list dsa_test_jsont) ~enc:(fun t ->
282
-
t.tests)
283
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
277
+
|> Json.Codec.Object.mem "jwk" Json.Codec.Value.t ~enc:(fun t -> t.jwk)
278
+
|> Json.Codec.Object.mem "key" eddsa_key_jsont ~enc:(fun t -> t.key)
279
+
|> Json.Codec.Object.mem "keyDer" Json.Codec.string ~enc:(fun t -> t.key_der)
280
+
|> Json.Codec.Object.mem "keyPem" Json.Codec.string ~enc:(fun t -> t.key_pem)
281
+
|> Json.Codec.Object.mem "type" Json.Codec.Value.t ~enc:(fun t -> t.type_)
282
+
|> Json.Codec.Object.mem "tests" (Json.Codec.list dsa_test_jsont)
283
+
~enc:(fun t -> t.tests)
284
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
284
285
285
286
type test_file = {
286
287
algorithm : json;
···
303
304
let show_test_file t = Fmt.str "%a" pp_test_file t
304
305
305
306
let test_file_jsont =
306
-
Jsont.Object.map ~kind:"test_file"
307
+
Json.Codec.Object.map ~kind:"test_file"
307
308
(fun
308
309
algorithm
309
310
generator_version
···
322
323
schema;
323
324
test_groups;
324
325
})
325
-
|> Jsont.Object.mem "algorithm" Jsont.json ~enc:(fun t -> t.algorithm)
326
-
|> Jsont.Object.mem "generatorVersion" Jsont.json ~enc:(fun t ->
326
+
|> Json.Codec.Object.mem "algorithm" Json.Codec.Value.t ~enc:(fun t ->
327
+
t.algorithm)
328
+
|> Json.Codec.Object.mem "generatorVersion" Json.Codec.Value.t ~enc:(fun t ->
327
329
t.generator_version)
328
-
|> Jsont.Object.mem "header" Jsont.json ~enc:(fun t -> t.header)
329
-
|> Jsont.Object.mem "notes" Jsont.json ~enc:(fun t -> t.notes)
330
-
|> Jsont.Object.mem "numberOfTests" Jsont.json ~enc:(fun t ->
330
+
|> Json.Codec.Object.mem "header" Json.Codec.Value.t ~enc:(fun t -> t.header)
331
+
|> Json.Codec.Object.mem "notes" Json.Codec.Value.t ~enc:(fun t -> t.notes)
332
+
|> Json.Codec.Object.mem "numberOfTests" Json.Codec.Value.t ~enc:(fun t ->
331
333
t.number_of_tests)
332
-
|> Jsont.Object.mem "schema" Jsont.json ~enc:(fun t -> t.schema)
333
-
|> Jsont.Object.mem "testGroups" (Jsont.list Jsont.json) ~enc:(fun t ->
334
-
t.test_groups)
335
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
334
+
|> Json.Codec.Object.mem "schema" Json.Codec.Value.t ~enc:(fun t -> t.schema)
335
+
|> Json.Codec.Object.mem "testGroups" (Json.Codec.list Json.Codec.Value.t)
336
+
~enc:(fun t -> t.test_groups)
337
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
336
338
337
-
let result = function Ok x -> x | Error s -> failwith s
339
+
let json_result = function
340
+
| Ok x -> x
341
+
| Error e -> failwith (Json.Error.to_string e)
338
342
339
343
let load_file_exn path =
340
344
let content = In_channel.with_open_bin path In_channel.input_all in
341
-
Jsont_bytesrw.decode_string test_file_jsont content |> result
345
+
Json.of_string test_file_jsont content |> json_result
342
346
343
347
let ecdh_test_group_exn json =
344
-
match Jsont_bytesrw.encode_string Jsont.json json with
345
-
| Error _ -> failwith "ecdh_test_group_exn: encode failed"
346
-
| Ok s -> Jsont_bytesrw.decode_string ecdh_test_group_jsont s |> result
348
+
Json.of_string ecdh_test_group_jsont (Json.Value.to_string json)
349
+
|> json_result
347
350
348
351
let ecdsa_test_group_exn json =
349
-
match Jsont_bytesrw.encode_string Jsont.json json with
350
-
| Error _ -> failwith "ecdsa_test_group_exn: encode failed"
351
-
| Ok s -> Jsont_bytesrw.decode_string ecdsa_test_group_jsont s |> result
352
+
Json.of_string ecdsa_test_group_jsont (Json.Value.to_string json)
353
+
|> json_result
352
354
353
355
let eddsa_test_group_exn json =
354
-
match Jsont_bytesrw.encode_string Jsont.json json with
355
-
| Error _ -> failwith "eddsa_test_group_exn: encode failed"
356
-
| Ok s -> Jsont_bytesrw.decode_string eddsa_test_group_jsont s |> result
356
+
Json.of_string eddsa_test_group_jsont (Json.Value.to_string json)
357
+
|> json_result
357
358
358
359
(* -- EC test vectors ---------------------------------------------------- *)
359
360
-1
ocaml-csrf/fuzz/dune
-1
ocaml-csrf/fuzz/dune
-1
ocaml-csv/fuzz/dune
-1
ocaml-csv/fuzz/dune
+6
-6
ocaml-csv/fuzz/fuzz_csv.ml
+6
-6
ocaml-csv/fuzz/fuzz_csv.ml
···
11
11
let csv_field_gen =
12
12
map [ bytes ] (fun s ->
13
13
String.to_seq s
14
-
|> Seq.filter (fun c ->
15
-
c <> ',' && c <> '\n' && c <> '\r' && c <> '"')
14
+
|> Seq.filter (fun c -> c <> ',' && c <> '\n' && c <> '\r' && c <> '"')
16
15
|> String.of_seq)
17
16
18
17
(* Generate a printable float string (no NaN/Inf — those don't
19
18
roundtrip through the default CSV float codec). *)
20
19
let float_str_gen =
21
20
map [ float ] (fun f ->
22
-
if Float.is_nan f || Float.is_infinite f then "0.0"
23
-
else string_of_float f)
21
+
if Float.is_nan f || Float.is_infinite f then "0.0" else string_of_float f)
24
22
25
23
(* Generate an int formatted as a string — exercises the int column
26
24
codec's string-parsing path. *)
···
184
182
failf "triple.b: expected %g, got %g" f b;
185
183
if not (String.equal c s) then
186
184
failf "triple.c: expected %S, got %S" s c
187
-
| Ok vs -> failf "triple roundtrip: expected 1 row, got %d" (List.length vs)
185
+
| Ok vs ->
186
+
failf "triple roundtrip: expected 1 row, got %d" (List.length vs)
188
187
189
188
(* {1 Column reorder invariance} *)
190
189
···
295
294
test_case "bool roundtrip" [ bool ] test_bool_roundtrip;
296
295
test_case "string roundtrip" [ csv_field_gen ] test_string_roundtrip;
297
296
test_case "pair roundtrip" [ int; csv_field_gen ] test_pair_roundtrip;
298
-
test_case "triple roundtrip" [ int; float; csv_field_gen ]
297
+
test_case "triple roundtrip"
298
+
[ int; float; csv_field_gen ]
299
299
test_triple_roundtrip;
300
300
test_case "column reorder" [ int; csv_field_gen ] test_reorder_invariance;
301
301
test_case "multi-row int" [ list int ] test_multi_row_int;
-1
ocaml-demod/fuzz/dune
-1
ocaml-demod/fuzz/dune
-1
ocaml-dsp/fuzz/dune
-1
ocaml-dsp/fuzz/dune
-1
ocaml-erasure/fuzz/dune
-1
ocaml-erasure/fuzz/dune
-1
ocaml-ewah/fuzz/dune
-1
ocaml-ewah/fuzz/dune
-1
ocaml-fdir/test/dune
-1
ocaml-fdir/test/dune
-1
ocaml-flexacm/fuzz/dune
-1
ocaml-flexacm/fuzz/dune
+15
-13
ocaml-freebox/lib/auth.ml
+15
-13
ocaml-freebox/lib/auth.ml
···
16
16
type result = { app_token : string; track_id : int }
17
17
18
18
let result_codec =
19
-
Json.Object.map ~kind:"result" (fun app_token track_id ->
19
+
Json.Codec.Object.map ~kind:"result" (fun app_token track_id ->
20
20
{ app_token; track_id })
21
-
|> Json.Object.mem "app_token" Json.string ~enc:(fun r -> r.app_token)
22
-
|> Json.Object.mem "track_id" Json.int ~enc:(fun r -> r.track_id)
23
-
|> Json.Object.skip_unknown |> Json.Object.finish
21
+
|> Json.Codec.Object.mem "app_token" Json.Codec.string ~enc:(fun r ->
22
+
r.app_token)
23
+
|> Json.Codec.Object.mem "track_id" Json.Codec.int ~enc:(fun r -> r.track_id)
24
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
24
25
25
26
type status_result = { status : string }
26
27
27
28
let status_result_codec =
28
-
Json.Object.map ~kind:"status_result" (fun status ->
29
+
Json.Codec.Object.map ~kind:"status_result" (fun status ->
29
30
{ status = Option.value ~default:"unknown" status })
30
-
|> Json.Object.opt_mem "status" Json.string ~enc:(fun r -> Some r.status)
31
-
|> Json.Object.skip_unknown |> Json.Object.finish
31
+
|> Json.Codec.Object.opt_mem "status" Json.Codec.string ~enc:(fun r ->
32
+
Some r.status)
33
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
32
34
33
35
type challenge_result = { challenge : string }
34
36
35
37
let challenge_result_codec =
36
-
Json.Object.map ~kind:"challenge_result" (fun challenge ->
38
+
Json.Codec.Object.map ~kind:"challenge_result" (fun challenge ->
37
39
{ challenge = Option.value ~default:"" challenge })
38
-
|> Json.Object.opt_mem "challenge" Json.string ~enc:(fun r ->
40
+
|> Json.Codec.Object.opt_mem "challenge" Json.Codec.string ~enc:(fun r ->
39
41
Some r.challenge)
40
-
|> Json.Object.skip_unknown |> Json.Object.finish
42
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
41
43
42
44
type session_result = { session_token : string }
43
45
44
46
let session_result_codec =
45
-
Json.Object.map ~kind:"session_result" (fun session_token ->
47
+
Json.Codec.Object.map ~kind:"session_result" (fun session_token ->
46
48
{ session_token = Option.value ~default:"" session_token })
47
-
|> Json.Object.opt_mem "session_token" Json.string ~enc:(fun r ->
49
+
|> Json.Codec.Object.opt_mem "session_token" Json.Codec.string ~enc:(fun r ->
48
50
Some r.session_token)
49
-
|> Json.Object.skip_unknown |> Json.Object.finish
51
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
50
52
51
53
(** {1 Token storage} *)
52
54
+23
-18
ocaml-freebox/lib/calls.ml
+23
-18
ocaml-freebox/lib/calls.ml
···
26
26
| s -> Unknown_type s
27
27
28
28
let call_codec : call Json.codec =
29
-
Json.Object.map ~kind:"call"
29
+
Json.Codec.Object.map ~kind:"call"
30
30
(fun id call_type datetime number name duration was_read contact_id ->
31
31
{
32
32
id = Option.value ~default:0 id;
···
38
38
was_read = Option.value ~default:false was_read;
39
39
contact_id;
40
40
})
41
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (c : call) -> Some c.id)
42
-
|> Json.Object.opt_mem "type" Json.string ~enc:(fun (_ : call) -> None)
43
-
|> Json.Object.opt_mem "datetime" Json.int ~enc:(fun (c : call) ->
41
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int ~enc:(fun (c : call) ->
42
+
Some c.id)
43
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.string ~enc:(fun (_ : call) ->
44
+
None)
45
+
|> Json.Codec.Object.opt_mem "datetime" Json.Codec.int ~enc:(fun (c : call) ->
44
46
Some c.datetime)
45
-
|> Json.Object.opt_mem "number" Json.string ~enc:(fun (c : call) ->
46
-
Some c.number)
47
-
|> Json.Object.opt_mem "name" Json.string ~enc:(fun (c : call) -> c.name)
48
-
|> Json.Object.opt_mem "duration" Json.int ~enc:(fun (c : call) ->
47
+
|> Json.Codec.Object.opt_mem "number" Json.Codec.string
48
+
~enc:(fun (c : call) -> Some c.number)
49
+
|> Json.Codec.Object.opt_mem "name" Json.Codec.string ~enc:(fun (c : call) ->
50
+
c.name)
51
+
|> Json.Codec.Object.opt_mem "duration" Json.Codec.int ~enc:(fun (c : call) ->
49
52
Some c.duration)
50
-
|> Json.Object.opt_mem "new" Json.bool ~enc:(fun (c : call) ->
53
+
|> Json.Codec.Object.opt_mem "new" Json.Codec.bool ~enc:(fun (c : call) ->
51
54
Some (not c.was_read))
52
-
|> Json.Object.opt_mem "contact_id" Json.int ~enc:(fun (c : call) ->
53
-
c.contact_id)
54
-
|> Json.Object.skip_unknown |> Json.Object.finish
55
+
|> Json.Codec.Object.opt_mem "contact_id" Json.Codec.int
56
+
~enc:(fun (c : call) -> c.contact_id)
57
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
55
58
56
59
(** {1 API functions} *)
57
60
58
61
let list_all http ~clock cfg =
59
62
Auth.with_session http ~clock cfg (fun token ->
60
-
unwrap_list (get http token "/call/log/" (Json.list call_codec)))
63
+
unwrap_list (get http token "/call/log/" (Json.Codec.list call_codec)))
61
64
62
65
let call http ~clock cfg id =
63
66
Auth.with_session http ~clock cfg (fun token ->
···
67
70
let mark_as_read http ~clock cfg id =
68
71
Auth.with_session http ~clock cfg (fun token ->
69
72
let data =
70
-
Json.Object.map ~kind:"mark_read" (fun _ -> ())
71
-
|> Json.Object.opt_mem "new" Json.bool ~enc:(fun () -> Some false)
72
-
|> Json.Object.finish
73
+
Json.Codec.Object.map ~kind:"mark_read" (fun _ -> ())
74
+
|> Json.Codec.Object.opt_mem "new" Json.Codec.bool ~enc:(fun () ->
75
+
Some false)
76
+
|> Json.Codec.Object.finish
73
77
in
74
78
unwrap_unit
75
79
(put http token (Fmt.str "/call/log/%d" id) data () call_codec))
···
77
81
let delete_call http ~clock cfg id =
78
82
Auth.with_session http ~clock cfg (fun token ->
79
83
unwrap_unit
80
-
(delete http token (Fmt.str "/call/log/%d" id) (Json.null ())))
84
+
(delete http token (Fmt.str "/call/log/%d" id) (Json.Codec.null ())))
81
85
82
86
let delete_all_calls http ~clock cfg =
83
87
Auth.with_session http ~clock cfg (fun token ->
84
-
unwrap_unit (delete http token "/call/log/delete_all/" (Json.null ())))
88
+
unwrap_unit
89
+
(delete http token "/call/log/delete_all/" (Json.Codec.null ())))
85
90
86
91
(** {1 Pretty printers} *)
87
92
+66
-61
ocaml-freebox/lib/connection.ml
+66
-61
ocaml-freebox/lib/connection.ml
···
68
68
| s -> Unknown_media s
69
69
70
70
let status_codec : status Json.codec =
71
-
Json.Object.map ~kind:"connection_status"
71
+
Json.Codec.Object.map ~kind:"connection_status"
72
72
(fun
73
73
state
74
74
media
···
95
95
bytes_down = Option.value ~default:0L bytes_down;
96
96
bytes_up = Option.value ~default:0L bytes_up;
97
97
})
98
-
|> Json.Object.opt_mem "state" Json.string ~enc:(fun (_ : status) -> None)
99
-
|> Json.Object.opt_mem "media" Json.string ~enc:(fun (_ : status) -> None)
100
-
|> Json.Object.opt_mem "type" Json.string ~enc:(fun (s : status) ->
101
-
Some s.conn_type)
102
-
|> Json.Object.opt_mem "ipv4" Json.string ~enc:(fun (s : status) -> s.ipv4)
103
-
|> Json.Object.opt_mem "ipv6" Json.string ~enc:(fun (s : status) -> s.ipv6)
104
-
|> Json.Object.opt_mem "rate_down" Json.int ~enc:(fun (s : status) ->
105
-
Some s.rate_down)
106
-
|> Json.Object.opt_mem "rate_up" Json.int ~enc:(fun (s : status) ->
107
-
Some s.rate_up)
108
-
|> Json.Object.opt_mem "bandwidth_down" Json.int ~enc:(fun (s : status) ->
109
-
Some s.bandwidth_down)
110
-
|> Json.Object.opt_mem "bandwidth_up" Json.int ~enc:(fun (s : status) ->
111
-
Some s.bandwidth_up)
112
-
|> Json.Object.opt_mem "bytes_down" Json.int64 ~enc:(fun (s : status) ->
113
-
Some s.bytes_down)
114
-
|> Json.Object.opt_mem "bytes_up" Json.int64 ~enc:(fun (s : status) ->
115
-
Some s.bytes_up)
116
-
|> Json.Object.skip_unknown |> Json.Object.finish
98
+
|> Json.Codec.Object.opt_mem "state" Json.Codec.string
99
+
~enc:(fun (_ : status) -> None)
100
+
|> Json.Codec.Object.opt_mem "media" Json.Codec.string
101
+
~enc:(fun (_ : status) -> None)
102
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.string
103
+
~enc:(fun (s : status) -> Some s.conn_type)
104
+
|> Json.Codec.Object.opt_mem "ipv4" Json.Codec.string
105
+
~enc:(fun (s : status) -> s.ipv4)
106
+
|> Json.Codec.Object.opt_mem "ipv6" Json.Codec.string
107
+
~enc:(fun (s : status) -> s.ipv6)
108
+
|> Json.Codec.Object.opt_mem "rate_down" Json.Codec.int
109
+
~enc:(fun (s : status) -> Some s.rate_down)
110
+
|> Json.Codec.Object.opt_mem "rate_up" Json.Codec.int
111
+
~enc:(fun (s : status) -> Some s.rate_up)
112
+
|> Json.Codec.Object.opt_mem "bandwidth_down" Json.Codec.int
113
+
~enc:(fun (s : status) -> Some s.bandwidth_down)
114
+
|> Json.Codec.Object.opt_mem "bandwidth_up" Json.Codec.int
115
+
~enc:(fun (s : status) -> Some s.bandwidth_up)
116
+
|> Json.Codec.Object.opt_mem "bytes_down" Json.Codec.int64
117
+
~enc:(fun (s : status) -> Some s.bytes_down)
118
+
|> Json.Codec.Object.opt_mem "bytes_up" Json.Codec.int64
119
+
~enc:(fun (s : status) -> Some s.bytes_up)
120
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
117
121
118
122
let config_codec : config Json.codec =
119
-
Json.Object.map ~kind:"connection_config"
123
+
Json.Codec.Object.map ~kind:"connection_config"
120
124
(fun ping remote_access remote_access_port wol adblock ->
121
125
{
122
126
ping = Option.value ~default:false ping;
···
125
129
wol = Option.value ~default:false wol;
126
130
adblock = Option.value ~default:false adblock;
127
131
})
128
-
|> Json.Object.opt_mem "ping" Json.bool ~enc:(fun (c : config) ->
132
+
|> Json.Codec.Object.opt_mem "ping" Json.Codec.bool ~enc:(fun (c : config) ->
129
133
Some c.ping)
130
-
|> Json.Object.opt_mem "remote_access" Json.bool ~enc:(fun (c : config) ->
131
-
Some c.remote_access)
132
-
|> Json.Object.opt_mem "remote_access_port" Json.int
134
+
|> Json.Codec.Object.opt_mem "remote_access" Json.Codec.bool
135
+
~enc:(fun (c : config) -> Some c.remote_access)
136
+
|> Json.Codec.Object.opt_mem "remote_access_port" Json.Codec.int
133
137
~enc:(fun (c : config) -> Some c.remote_access_port)
134
-
|> Json.Object.opt_mem "wol" Json.bool ~enc:(fun (c : config) -> Some c.wol)
135
-
|> Json.Object.opt_mem "adblock" Json.bool ~enc:(fun (c : config) ->
136
-
Some c.adblock)
137
-
|> Json.Object.skip_unknown |> Json.Object.finish
138
+
|> Json.Codec.Object.opt_mem "wol" Json.Codec.bool ~enc:(fun (c : config) ->
139
+
Some c.wol)
140
+
|> Json.Codec.Object.opt_mem "adblock" Json.Codec.bool
141
+
~enc:(fun (c : config) -> Some c.adblock)
142
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
138
143
139
144
let ipv6_config_codec : ipv6_config Json.codec =
140
-
Json.Object.map ~kind:"ipv6_config" (fun enabled ll delegations ->
145
+
Json.Codec.Object.map ~kind:"ipv6_config" (fun enabled ll delegations ->
141
146
{
142
147
ipv6_enabled = Option.value ~default:false enabled;
143
148
ipv6_ll = ll;
144
149
delegations = Option.value ~default:[] delegations;
145
150
})
146
-
|> Json.Object.opt_mem "ipv6_enabled" Json.bool
151
+
|> Json.Codec.Object.opt_mem "ipv6_enabled" Json.Codec.bool
147
152
~enc:(fun (c : ipv6_config) -> Some c.ipv6_enabled)
148
-
|> Json.Object.opt_mem "ipv6_ll" Json.string ~enc:(fun (c : ipv6_config) ->
149
-
c.ipv6_ll)
150
-
|> Json.Object.opt_mem "delegations" (Json.list Json.string)
153
+
|> Json.Codec.Object.opt_mem "ipv6_ll" Json.Codec.string
154
+
~enc:(fun (c : ipv6_config) -> c.ipv6_ll)
155
+
|> Json.Codec.Object.opt_mem "delegations" (Json.Codec.list Json.Codec.string)
151
156
~enc:(fun (c : ipv6_config) -> Some c.delegations)
152
-
|> Json.Object.skip_unknown |> Json.Object.finish
157
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
153
158
154
159
let xdsl_status_codec : xdsl_status Json.codec =
155
-
Json.Object.map ~kind:"xdsl_status"
160
+
Json.Codec.Object.map ~kind:"xdsl_status"
156
161
(fun state protocol modulation rate_down rate_up snr_down snr_up ->
157
162
{
158
163
xdsl_state = Option.value ~default:"" state;
···
163
168
snr_down = Option.value ~default:0.0 snr_down;
164
169
snr_up = Option.value ~default:0.0 snr_up;
165
170
})
166
-
|> Json.Object.opt_mem "status" Json.string ~enc:(fun (x : xdsl_status) ->
167
-
Some x.xdsl_state)
168
-
|> Json.Object.opt_mem "protocol" Json.string ~enc:(fun (x : xdsl_status) ->
169
-
Some x.protocol)
170
-
|> Json.Object.opt_mem "modulation" Json.string
171
+
|> Json.Codec.Object.opt_mem "status" Json.Codec.string
172
+
~enc:(fun (x : xdsl_status) -> Some x.xdsl_state)
173
+
|> Json.Codec.Object.opt_mem "protocol" Json.Codec.string
174
+
~enc:(fun (x : xdsl_status) -> Some x.protocol)
175
+
|> Json.Codec.Object.opt_mem "modulation" Json.Codec.string
171
176
~enc:(fun (x : xdsl_status) -> Some x.modulation)
172
-
|> Json.Object.opt_mem "rate_down" Json.int ~enc:(fun (x : xdsl_status) ->
173
-
Some x.rate_down)
174
-
|> Json.Object.opt_mem "rate_up" Json.int ~enc:(fun (x : xdsl_status) ->
175
-
Some x.rate_up)
176
-
|> Json.Object.opt_mem "snr_down" Json.number ~enc:(fun (x : xdsl_status) ->
177
-
Some x.snr_down)
178
-
|> Json.Object.opt_mem "snr_up" Json.number ~enc:(fun (x : xdsl_status) ->
179
-
Some x.snr_up)
180
-
|> Json.Object.skip_unknown |> Json.Object.finish
177
+
|> Json.Codec.Object.opt_mem "rate_down" Json.Codec.int
178
+
~enc:(fun (x : xdsl_status) -> Some x.rate_down)
179
+
|> Json.Codec.Object.opt_mem "rate_up" Json.Codec.int
180
+
~enc:(fun (x : xdsl_status) -> Some x.rate_up)
181
+
|> Json.Codec.Object.opt_mem "snr_down" Json.Codec.number
182
+
~enc:(fun (x : xdsl_status) -> Some x.snr_down)
183
+
|> Json.Codec.Object.opt_mem "snr_up" Json.Codec.number
184
+
~enc:(fun (x : xdsl_status) -> Some x.snr_up)
185
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
181
186
182
187
let ftth_status_codec : ftth_status Json.codec =
183
-
Json.Object.map ~kind:"ftth_status"
188
+
Json.Codec.Object.map ~kind:"ftth_status"
184
189
(fun sfp_present sfp_model sfp_vendor link sfp_pwr_tx sfp_pwr_rx ->
185
190
{
186
191
sfp_present = Option.value ~default:false sfp_present;
···
190
195
sfp_pwr_tx;
191
196
sfp_pwr_rx;
192
197
})
193
-
|> Json.Object.opt_mem "sfp_present" Json.bool
198
+
|> Json.Codec.Object.opt_mem "sfp_present" Json.Codec.bool
194
199
~enc:(fun (f : ftth_status) -> Some f.sfp_present)
195
-
|> Json.Object.opt_mem "sfp_model" Json.string
200
+
|> Json.Codec.Object.opt_mem "sfp_model" Json.Codec.string
196
201
~enc:(fun (f : ftth_status) -> f.sfp_model)
197
-
|> Json.Object.opt_mem "sfp_vendor" Json.string
202
+
|> Json.Codec.Object.opt_mem "sfp_vendor" Json.Codec.string
198
203
~enc:(fun (f : ftth_status) -> f.sfp_vendor)
199
-
|> Json.Object.opt_mem "link" Json.bool ~enc:(fun (f : ftth_status) ->
200
-
Some f.link)
201
-
|> Json.Object.opt_mem "sfp_pwr_tx" Json.int ~enc:(fun (f : ftth_status) ->
202
-
f.sfp_pwr_tx)
203
-
|> Json.Object.opt_mem "sfp_pwr_rx" Json.int ~enc:(fun (f : ftth_status) ->
204
-
f.sfp_pwr_rx)
205
-
|> Json.Object.skip_unknown |> Json.Object.finish
204
+
|> Json.Codec.Object.opt_mem "link" Json.Codec.bool
205
+
~enc:(fun (f : ftth_status) -> Some f.link)
206
+
|> Json.Codec.Object.opt_mem "sfp_pwr_tx" Json.Codec.int
207
+
~enc:(fun (f : ftth_status) -> f.sfp_pwr_tx)
208
+
|> Json.Codec.Object.opt_mem "sfp_pwr_rx" Json.Codec.int
209
+
~enc:(fun (f : ftth_status) -> f.sfp_pwr_rx)
210
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
206
211
207
212
(** {1 API functions} *)
208
213
+42
-37
ocaml-freebox/lib/downloads.ml
+42
-37
ocaml-freebox/lib/downloads.ml
···
69
69
| s -> Unknown_type s
70
70
71
71
let download_codec : download Json.codec =
72
-
Json.Object.map ~kind:"download"
72
+
Json.Codec.Object.map ~kind:"download"
73
73
(fun
74
74
id
75
75
name
···
104
104
eta = Option.value ~default:0 eta;
105
105
download_dir = Option.value ~default:"" download_dir;
106
106
})
107
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (d : download) -> Some d.id)
108
-
|> Json.Object.opt_mem "name" Json.string ~enc:(fun (d : download) ->
109
-
Some d.name)
110
-
|> Json.Object.opt_mem "status" Json.string ~enc:(fun (_ : download) ->
111
-
None)
112
-
|> Json.Object.opt_mem "type" Json.string ~enc:(fun (_ : download) -> None)
113
-
|> Json.Object.opt_mem "size" Json.int64 ~enc:(fun (d : download) ->
114
-
Some d.size)
115
-
|> Json.Object.opt_mem "rx_bytes" Json.int64 ~enc:(fun (d : download) ->
116
-
Some d.downloaded)
117
-
|> Json.Object.opt_mem "tx_bytes" Json.int64 ~enc:(fun (d : download) ->
118
-
Some d.uploaded)
119
-
|> Json.Object.opt_mem "rx_rate" Json.int ~enc:(fun (d : download) ->
120
-
Some d.rx_rate)
121
-
|> Json.Object.opt_mem "tx_rate" Json.int ~enc:(fun (d : download) ->
122
-
Some d.tx_rate)
123
-
|> Json.Object.opt_mem "rx_pct" Json.int ~enc:(fun (d : download) ->
124
-
Some d.rx_pct)
125
-
|> Json.Object.opt_mem "tx_pct" Json.int ~enc:(fun (d : download) ->
126
-
Some d.tx_pct)
127
-
|> Json.Object.opt_mem "error" Json.string ~enc:(fun (d : download) ->
128
-
d.error)
129
-
|> Json.Object.opt_mem "created_ts" Json.int ~enc:(fun (d : download) ->
130
-
Some d.created_ts)
131
-
|> Json.Object.opt_mem "eta" Json.int ~enc:(fun (d : download) ->
107
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int ~enc:(fun (d : download) ->
108
+
Some d.id)
109
+
|> Json.Codec.Object.opt_mem "name" Json.Codec.string
110
+
~enc:(fun (d : download) -> Some d.name)
111
+
|> Json.Codec.Object.opt_mem "status" Json.Codec.string
112
+
~enc:(fun (_ : download) -> None)
113
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.string
114
+
~enc:(fun (_ : download) -> None)
115
+
|> Json.Codec.Object.opt_mem "size" Json.Codec.int64
116
+
~enc:(fun (d : download) -> Some d.size)
117
+
|> Json.Codec.Object.opt_mem "rx_bytes" Json.Codec.int64
118
+
~enc:(fun (d : download) -> Some d.downloaded)
119
+
|> Json.Codec.Object.opt_mem "tx_bytes" Json.Codec.int64
120
+
~enc:(fun (d : download) -> Some d.uploaded)
121
+
|> Json.Codec.Object.opt_mem "rx_rate" Json.Codec.int
122
+
~enc:(fun (d : download) -> Some d.rx_rate)
123
+
|> Json.Codec.Object.opt_mem "tx_rate" Json.Codec.int
124
+
~enc:(fun (d : download) -> Some d.tx_rate)
125
+
|> Json.Codec.Object.opt_mem "rx_pct" Json.Codec.int
126
+
~enc:(fun (d : download) -> Some d.rx_pct)
127
+
|> Json.Codec.Object.opt_mem "tx_pct" Json.Codec.int
128
+
~enc:(fun (d : download) -> Some d.tx_pct)
129
+
|> Json.Codec.Object.opt_mem "error" Json.Codec.string
130
+
~enc:(fun (d : download) -> d.error)
131
+
|> Json.Codec.Object.opt_mem "created_ts" Json.Codec.int
132
+
~enc:(fun (d : download) -> Some d.created_ts)
133
+
|> Json.Codec.Object.opt_mem "eta" Json.Codec.int ~enc:(fun (d : download) ->
132
134
Some d.eta)
133
-
|> Json.Object.opt_mem "download_dir" Json.string
135
+
|> Json.Codec.Object.opt_mem "download_dir" Json.Codec.string
134
136
~enc:(fun (d : download) -> Some d.download_dir)
135
-
|> Json.Object.skip_unknown |> Json.Object.finish
137
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
136
138
137
139
let config_codec : download_config Json.codec =
138
-
Json.Object.map ~kind:"download_config"
140
+
Json.Codec.Object.map ~kind:"download_config"
139
141
(fun max_downloading_tasks download_dir throttling_rate throttling_mode ->
140
142
{
141
143
max_downloading_tasks = Option.value ~default:3 max_downloading_tasks;
···
143
145
throttling_rate = Option.value ~default:0 throttling_rate;
144
146
throttling_mode = Option.value ~default:"normal" throttling_mode;
145
147
})
146
-
|> Json.Object.opt_mem "max_downloading_tasks" Json.int
148
+
|> Json.Codec.Object.opt_mem "max_downloading_tasks" Json.Codec.int
147
149
~enc:(fun (c : download_config) -> Some c.max_downloading_tasks)
148
-
|> Json.Object.opt_mem "download_dir" Json.string
150
+
|> Json.Codec.Object.opt_mem "download_dir" Json.Codec.string
149
151
~enc:(fun (c : download_config) -> Some c.download_dir)
150
-
|> Json.Object.opt_mem "throttling_rate" Json.int
152
+
|> Json.Codec.Object.opt_mem "throttling_rate" Json.Codec.int
151
153
~enc:(fun (c : download_config) -> Some c.throttling_rate)
152
-
|> Json.Object.opt_mem "throttling_mode" Json.string
154
+
|> Json.Codec.Object.opt_mem "throttling_mode" Json.Codec.string
153
155
~enc:(fun (c : download_config) -> Some c.throttling_mode)
154
-
|> Json.Object.skip_unknown |> Json.Object.finish
156
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
155
157
156
158
(** {1 API functions} *)
157
159
158
160
let list_all http ~clock cfg =
159
161
Auth.with_session http ~clock cfg (fun token ->
160
-
unwrap_list (get http token "/downloads/" (Json.list download_codec)))
162
+
unwrap_list
163
+
(get http token "/downloads/" (Json.Codec.list download_codec)))
161
164
162
165
let download http ~clock cfg id =
163
166
Auth.with_session http ~clock cfg (fun token ->
···
167
170
let delete_download http ~clock cfg id =
168
171
Auth.with_session http ~clock cfg (fun token ->
169
172
unwrap_unit
170
-
(delete http token (Fmt.str "/downloads/%d" id) (Json.null ())))
173
+
(delete http token (Fmt.str "/downloads/%d" id) (Json.Codec.null ())))
171
174
172
175
let erase_download http ~clock cfg id =
173
176
Auth.with_session http ~clock cfg (fun token ->
174
177
unwrap_unit
175
-
(delete http token (Fmt.str "/downloads/%d/erase" id) (Json.null ())))
178
+
(delete http token
179
+
(Fmt.str "/downloads/%d/erase" id)
180
+
(Json.Codec.null ())))
176
181
177
182
let config http ~clock cfg =
178
183
Auth.with_session http ~clock cfg (fun token ->
-1
ocaml-freebox/lib/dune
-1
ocaml-freebox/lib/dune
+17
-15
ocaml-freebox/lib/firewall.ml
+17
-15
ocaml-freebox/lib/firewall.ml
···
31
31
}
32
32
33
33
let port_forward_json_codec =
34
-
Json.Object.map ~kind:"port_forward"
34
+
Json.Codec.Object.map ~kind:"port_forward"
35
35
(fun
36
36
id enabled comment lan_ip lan_port wan_port_start wan_port_end ip_proto ->
37
37
{
···
44
44
pf_wan_port_end = Option.value ~default:0 wan_port_end;
45
45
pf_ip_proto = Option.value ~default:"tcp" ip_proto;
46
46
})
47
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun p -> Some p.pf_id)
48
-
|> Json.Object.opt_mem "enabled" Json.bool ~enc:(fun p -> Some p.pf_enabled)
49
-
|> Json.Object.opt_mem "comment" Json.string ~enc:(fun p ->
47
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int ~enc:(fun p -> Some p.pf_id)
48
+
|> Json.Codec.Object.opt_mem "enabled" Json.Codec.bool ~enc:(fun p ->
49
+
Some p.pf_enabled)
50
+
|> Json.Codec.Object.opt_mem "comment" Json.Codec.string ~enc:(fun p ->
50
51
Some p.pf_comment)
51
-
|> Json.Object.opt_mem "lan_ip" Json.string ~enc:(fun p -> Some p.pf_lan_ip)
52
-
|> Json.Object.opt_mem "lan_port" Json.int ~enc:(fun p ->
52
+
|> Json.Codec.Object.opt_mem "lan_ip" Json.Codec.string ~enc:(fun p ->
53
+
Some p.pf_lan_ip)
54
+
|> Json.Codec.Object.opt_mem "lan_port" Json.Codec.int ~enc:(fun p ->
53
55
Some p.pf_lan_port)
54
-
|> Json.Object.opt_mem "wan_port_start" Json.int ~enc:(fun p ->
56
+
|> Json.Codec.Object.opt_mem "wan_port_start" Json.Codec.int ~enc:(fun p ->
55
57
Some p.pf_wan_port_start)
56
-
|> Json.Object.opt_mem "wan_port_end" Json.int ~enc:(fun p ->
58
+
|> Json.Codec.Object.opt_mem "wan_port_end" Json.Codec.int ~enc:(fun p ->
57
59
Some p.pf_wan_port_end)
58
-
|> Json.Object.opt_mem "ip_proto" Json.string ~enc:(fun p ->
60
+
|> Json.Codec.Object.opt_mem "ip_proto" Json.Codec.string ~enc:(fun p ->
59
61
Some p.pf_ip_proto)
60
-
|> Json.Object.skip_unknown |> Json.Object.finish
62
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
61
63
62
64
type dmz_json = { dmz_enabled : bool; dmz_ip : string option }
63
65
64
66
let dmz_json_codec =
65
-
Json.Object.map ~kind:"dmz" (fun enabled ip ->
67
+
Json.Codec.Object.map ~kind:"dmz" (fun enabled ip ->
66
68
{ dmz_enabled = Option.value ~default:false enabled; dmz_ip = ip })
67
-
|> Json.Object.opt_mem "enabled" Json.bool ~enc:(fun d ->
69
+
|> Json.Codec.Object.opt_mem "enabled" Json.Codec.bool ~enc:(fun d ->
68
70
Some d.dmz_enabled)
69
-
|> Json.Object.opt_mem "ip" Json.string ~enc:(fun d -> d.dmz_ip)
70
-
|> Json.Object.skip_unknown |> Json.Object.finish
71
+
|> Json.Codec.Object.opt_mem "ip" Json.Codec.string ~enc:(fun d -> d.dmz_ip)
72
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
71
73
72
74
(** {1 Conversions} *)
73
75
···
90
92
match
91
93
unwrap_list
92
94
(get http session_token "/fw/redir/"
93
-
(Json.list port_forward_json_codec))
95
+
(Json.Codec.list port_forward_json_codec))
94
96
with
95
97
| Error e -> Error e
96
98
| Ok rules -> Ok (List.map pf_json_to_port_forward rules))
+54
-44
ocaml-freebox/lib/fs.ml
+54
-44
ocaml-freebox/lib/fs.ml
···
63
63
| s -> Unknown_type s
64
64
65
65
let file_info_codec : file_info Json.codec =
66
-
Json.Object.map ~kind:"file_info"
66
+
Json.Codec.Object.map ~kind:"file_info"
67
67
(fun name path file_type size modification index link hidden ->
68
68
{
69
69
name = Option.value ~default:"" name;
···
75
75
link = Option.value ~default:false link;
76
76
hidden = Option.value ~default:false hidden;
77
77
})
78
-
|> Json.Object.opt_mem "name" Json.string ~enc:(fun (f : file_info) ->
79
-
Some f.name)
80
-
|> Json.Object.opt_mem "path" Json.string ~enc:(fun (f : file_info) ->
81
-
Some f.path)
82
-
|> Json.Object.opt_mem "type" Json.string ~enc:(fun (_ : file_info) -> None)
83
-
|> Json.Object.opt_mem "size" Json.int64 ~enc:(fun (f : file_info) ->
84
-
Some f.size)
85
-
|> Json.Object.opt_mem "modification" Json.int ~enc:(fun (f : file_info) ->
86
-
Some f.modification)
87
-
|> Json.Object.opt_mem "index" Json.int ~enc:(fun (f : file_info) ->
88
-
Some f.index)
89
-
|> Json.Object.opt_mem "link" Json.bool ~enc:(fun (f : file_info) ->
90
-
Some f.link)
91
-
|> Json.Object.opt_mem "hidden" Json.bool ~enc:(fun (f : file_info) ->
92
-
Some f.hidden)
93
-
|> Json.Object.skip_unknown |> Json.Object.finish
78
+
|> Json.Codec.Object.opt_mem "name" Json.Codec.string
79
+
~enc:(fun (f : file_info) -> Some f.name)
80
+
|> Json.Codec.Object.opt_mem "path" Json.Codec.string
81
+
~enc:(fun (f : file_info) -> Some f.path)
82
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.string
83
+
~enc:(fun (_ : file_info) -> None)
84
+
|> Json.Codec.Object.opt_mem "size" Json.Codec.int64
85
+
~enc:(fun (f : file_info) -> Some f.size)
86
+
|> Json.Codec.Object.opt_mem "modification" Json.Codec.int
87
+
~enc:(fun (f : file_info) -> Some f.modification)
88
+
|> Json.Codec.Object.opt_mem "index" Json.Codec.int
89
+
~enc:(fun (f : file_info) -> Some f.index)
90
+
|> Json.Codec.Object.opt_mem "link" Json.Codec.bool
91
+
~enc:(fun (f : file_info) -> Some f.link)
92
+
|> Json.Codec.Object.opt_mem "hidden" Json.Codec.bool
93
+
~enc:(fun (f : file_info) -> Some f.hidden)
94
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
94
95
95
96
let task_type_of_string = function
96
97
| "cp" -> Cp
···
111
112
| s -> Unknown_state s
112
113
113
114
let task_codec : task Json.codec =
114
-
Json.Object.map ~kind:"task"
115
+
Json.Codec.Object.map ~kind:"task"
115
116
(fun
116
117
id
117
118
task_type
···
150
151
total_bytes_done = Option.value ~default:0L total_bytes_done;
151
152
rate;
152
153
})
153
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (t : task) -> Some t.id)
154
-
|> Json.Object.opt_mem "type" Json.string ~enc:(fun (_ : task) -> None)
155
-
|> Json.Object.opt_mem "state" Json.string ~enc:(fun (_ : task) -> None)
156
-
|> Json.Object.opt_mem "error" Json.string ~enc:(fun (t : task) -> t.error)
157
-
|> Json.Object.opt_mem "created_ts" Json.int ~enc:(fun (t : task) ->
158
-
Some t.created_ts)
159
-
|> Json.Object.opt_mem "started_ts" Json.int ~enc:(fun (t : task) ->
160
-
t.started_ts)
161
-
|> Json.Object.opt_mem "done_ts" Json.int ~enc:(fun (t : task) -> t.done_ts)
162
-
|> Json.Object.opt_mem "duration" Json.int ~enc:(fun (t : task) ->
154
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int ~enc:(fun (t : task) ->
155
+
Some t.id)
156
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.string ~enc:(fun (_ : task) ->
157
+
None)
158
+
|> Json.Codec.Object.opt_mem "state" Json.Codec.string ~enc:(fun (_ : task) ->
159
+
None)
160
+
|> Json.Codec.Object.opt_mem "error" Json.Codec.string ~enc:(fun (t : task) ->
161
+
t.error)
162
+
|> Json.Codec.Object.opt_mem "created_ts" Json.Codec.int
163
+
~enc:(fun (t : task) -> Some t.created_ts)
164
+
|> Json.Codec.Object.opt_mem "started_ts" Json.Codec.int
165
+
~enc:(fun (t : task) -> t.started_ts)
166
+
|> Json.Codec.Object.opt_mem "done_ts" Json.Codec.int ~enc:(fun (t : task) ->
167
+
t.done_ts)
168
+
|> Json.Codec.Object.opt_mem "duration" Json.Codec.int ~enc:(fun (t : task) ->
163
169
t.duration)
164
-
|> Json.Object.opt_mem "progress" Json.int ~enc:(fun (t : task) ->
170
+
|> Json.Codec.Object.opt_mem "progress" Json.Codec.int ~enc:(fun (t : task) ->
165
171
Some t.progress)
166
-
|> Json.Object.opt_mem "eta" Json.int ~enc:(fun (t : task) -> t.eta)
167
-
|> Json.Object.opt_mem "from" Json.string ~enc:(fun (t : task) -> t.from)
168
-
|> Json.Object.opt_mem "to" Json.string ~enc:(fun (t : task) -> t.to_)
169
-
|> Json.Object.opt_mem "nfiles" Json.int ~enc:(fun (t : task) ->
172
+
|> Json.Codec.Object.opt_mem "eta" Json.Codec.int ~enc:(fun (t : task) ->
173
+
t.eta)
174
+
|> Json.Codec.Object.opt_mem "from" Json.Codec.string ~enc:(fun (t : task) ->
175
+
t.from)
176
+
|> Json.Codec.Object.opt_mem "to" Json.Codec.string ~enc:(fun (t : task) ->
177
+
t.to_)
178
+
|> Json.Codec.Object.opt_mem "nfiles" Json.Codec.int ~enc:(fun (t : task) ->
170
179
Some t.nfiles)
171
-
|> Json.Object.opt_mem "nfiles_done" Json.int ~enc:(fun (t : task) ->
172
-
Some t.nfiles_done)
173
-
|> Json.Object.opt_mem "total_bytes" Json.int64 ~enc:(fun (t : task) ->
174
-
Some t.total_bytes)
175
-
|> Json.Object.opt_mem "total_bytes_done" Json.int64 ~enc:(fun (t : task) ->
176
-
Some t.total_bytes_done)
177
-
|> Json.Object.opt_mem "rate" Json.int ~enc:(fun (t : task) -> t.rate)
178
-
|> Json.Object.skip_unknown |> Json.Object.finish
180
+
|> Json.Codec.Object.opt_mem "nfiles_done" Json.Codec.int
181
+
~enc:(fun (t : task) -> Some t.nfiles_done)
182
+
|> Json.Codec.Object.opt_mem "total_bytes" Json.Codec.int64
183
+
~enc:(fun (t : task) -> Some t.total_bytes)
184
+
|> Json.Codec.Object.opt_mem "total_bytes_done" Json.Codec.int64
185
+
~enc:(fun (t : task) -> Some t.total_bytes_done)
186
+
|> Json.Codec.Object.opt_mem "rate" Json.Codec.int ~enc:(fun (t : task) ->
187
+
t.rate)
188
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
179
189
180
190
(** {1 API functions} *)
181
191
···
185
195
unwrap_list
186
196
(get http token
187
197
(Fmt.str "/fs/ls/%s" encoded_path)
188
-
(Json.list file_info_codec)))
198
+
(Json.Codec.list file_info_codec)))
189
199
190
200
let file_info http ~clock cfg path =
191
201
Auth.with_session http ~clock cfg (fun token ->
···
195
205
196
206
let tasks http ~clock cfg =
197
207
Auth.with_session http ~clock cfg (fun token ->
198
-
unwrap_list (get http token "/fs/tasks/" (Json.list task_codec)))
208
+
unwrap_list (get http token "/fs/tasks/" (Json.Codec.list task_codec)))
199
209
200
210
let task http ~clock cfg id =
201
211
Auth.with_session http ~clock cfg (fun token ->
···
205
215
let delete_task http ~clock cfg id =
206
216
Auth.with_session http ~clock cfg (fun token ->
207
217
unwrap_unit
208
-
(delete http token (Fmt.str "/fs/tasks/%d" id) (Json.null ())))
218
+
(delete http token (Fmt.str "/fs/tasks/%d" id) (Json.Codec.null ())))
209
219
210
220
(** {1 Pretty printers} *)
211
221
+38
-31
ocaml-freebox/lib/hosts.ml
+38
-31
ocaml-freebox/lib/hosts.ml
···
37
37
type l2ident = { id : string }
38
38
39
39
let l2ident_codec =
40
-
Json.Object.map ~kind:"l2ident" (fun id ->
40
+
Json.Codec.Object.map ~kind:"l2ident" (fun id ->
41
41
{ id = Option.value ~default:"" id })
42
-
|> Json.Object.opt_mem "id" Json.string ~enc:(fun l -> Some l.id)
43
-
|> Json.Object.skip_unknown |> Json.Object.finish
42
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.string ~enc:(fun l -> Some l.id)
43
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
44
44
45
45
type l3conn = { addr : string }
46
46
47
47
let l3conn_codec =
48
-
Json.Object.map ~kind:"l3conn" (fun addr ->
48
+
Json.Codec.Object.map ~kind:"l3conn" (fun addr ->
49
49
{ addr = Option.value ~default:"" addr })
50
-
|> Json.Object.opt_mem "addr" Json.string ~enc:(fun l -> Some l.addr)
51
-
|> Json.Object.skip_unknown |> Json.Object.finish
50
+
|> Json.Codec.Object.opt_mem "addr" Json.Codec.string ~enc:(fun l ->
51
+
Some l.addr)
52
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
52
53
53
54
type lan_host_json = {
54
55
l2ident : l2ident option;
···
65
66
}
66
67
67
68
let lan_host_json_codec =
68
-
Json.Object.map ~kind:"lan_host"
69
+
Json.Codec.Object.map ~kind:"lan_host"
69
70
(fun
70
71
l2ident
71
72
primary_name
···
92
93
access_point;
93
94
l3connectivities = Option.value ~default:[] l3connectivities;
94
95
})
95
-
|> Json.Object.opt_mem "l2ident" l2ident_codec ~enc:(fun h -> h.l2ident)
96
-
|> Json.Object.opt_mem "primary_name" Json.string ~enc:(fun h ->
96
+
|> Json.Codec.Object.opt_mem "l2ident" l2ident_codec ~enc:(fun h -> h.l2ident)
97
+
|> Json.Codec.Object.opt_mem "primary_name" Json.Codec.string ~enc:(fun h ->
97
98
h.primary_name)
98
-
|> Json.Object.opt_mem "vendor_name" Json.string ~enc:(fun h ->
99
+
|> Json.Codec.Object.opt_mem "vendor_name" Json.Codec.string ~enc:(fun h ->
99
100
h.vendor_name)
100
-
|> Json.Object.opt_mem "host_type" Json.string ~enc:(fun h -> h.host_type)
101
-
|> Json.Object.opt_mem "active" Json.bool ~enc:(fun h -> Some h.active)
102
-
|> Json.Object.opt_mem "reachable" Json.bool ~enc:(fun h ->
101
+
|> Json.Codec.Object.opt_mem "host_type" Json.Codec.string ~enc:(fun h ->
102
+
h.host_type)
103
+
|> Json.Codec.Object.opt_mem "active" Json.Codec.bool ~enc:(fun h ->
104
+
Some h.active)
105
+
|> Json.Codec.Object.opt_mem "reachable" Json.Codec.bool ~enc:(fun h ->
103
106
Some h.reachable)
104
-
|> Json.Object.opt_mem "last_activity" Json.number ~enc:(fun h ->
107
+
|> Json.Codec.Object.opt_mem "last_activity" Json.Codec.number ~enc:(fun h ->
105
108
h.last_activity)
106
-
|> Json.Object.opt_mem "last_time_reachable" Json.number ~enc:(fun h ->
107
-
h.last_time_reachable)
108
-
|> Json.Object.opt_mem "first_activity" Json.number ~enc:(fun h ->
109
+
|> Json.Codec.Object.opt_mem "last_time_reachable" Json.Codec.number
110
+
~enc:(fun h -> h.last_time_reachable)
111
+
|> Json.Codec.Object.opt_mem "first_activity" Json.Codec.number ~enc:(fun h ->
109
112
h.first_activity)
110
-
|> Json.Object.opt_mem "access_point" Json.string ~enc:(fun h ->
113
+
|> Json.Codec.Object.opt_mem "access_point" Json.Codec.string ~enc:(fun h ->
111
114
h.access_point)
112
-
|> Json.Object.opt_mem "l3connectivities" (Json.list l3conn_codec)
115
+
|> Json.Codec.Object.opt_mem "l3connectivities" (Json.Codec.list l3conn_codec)
113
116
~enc:(fun h -> Some h.l3connectivities)
114
-
|> Json.Object.skip_unknown |> Json.Object.finish
117
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
115
118
116
119
type dhcp_lease_json = {
117
120
json_mac : string;
···
123
126
}
124
127
125
128
let dhcp_lease_json_codec =
126
-
Json.Object.map ~kind:"dhcp_lease"
129
+
Json.Codec.Object.map ~kind:"dhcp_lease"
127
130
(fun mac ip hostname assign_time refresh_time is_static ->
128
131
{
129
132
json_mac = Option.value ~default:"" mac;
···
133
136
json_refresh_time = Option.value ~default:0 refresh_time;
134
137
json_is_static = Option.value ~default:false is_static;
135
138
})
136
-
|> Json.Object.opt_mem "mac" Json.string ~enc:(fun d -> Some d.json_mac)
137
-
|> Json.Object.opt_mem "ip" Json.string ~enc:(fun d -> Some d.json_ip)
138
-
|> Json.Object.opt_mem "hostname" Json.string ~enc:(fun d ->
139
+
|> Json.Codec.Object.opt_mem "mac" Json.Codec.string ~enc:(fun d ->
140
+
Some d.json_mac)
141
+
|> Json.Codec.Object.opt_mem "ip" Json.Codec.string ~enc:(fun d ->
142
+
Some d.json_ip)
143
+
|> Json.Codec.Object.opt_mem "hostname" Json.Codec.string ~enc:(fun d ->
139
144
Some d.json_hostname)
140
-
|> Json.Object.opt_mem "assign_time" Json.int ~enc:(fun d ->
145
+
|> Json.Codec.Object.opt_mem "assign_time" Json.Codec.int ~enc:(fun d ->
141
146
Some d.json_assign_time)
142
-
|> Json.Object.opt_mem "refresh_time" Json.int ~enc:(fun d ->
147
+
|> Json.Codec.Object.opt_mem "refresh_time" Json.Codec.int ~enc:(fun d ->
143
148
Some d.json_refresh_time)
144
-
|> Json.Object.opt_mem "is_static" Json.bool ~enc:(fun d ->
149
+
|> Json.Codec.Object.opt_mem "is_static" Json.Codec.bool ~enc:(fun d ->
145
150
Some d.json_is_static)
146
-
|> Json.Object.skip_unknown |> Json.Object.finish
151
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
147
152
148
153
(** {1 Conversions} *)
149
154
···
199
204
200
205
let lan_hosts http session_token =
201
206
match
202
-
get http session_token "/lan/browser/pub/" (Json.list lan_host_json_codec)
207
+
get http session_token "/lan/browser/pub/"
208
+
(Json.Codec.list lan_host_json_codec)
203
209
with
204
210
| Error e -> Error e
205
211
| Ok None -> Ok []
···
210
216
let dhcp_leases http session_token =
211
217
match
212
218
get http session_token "/dhcp/dynamic_lease/"
213
-
(Json.list dhcp_lease_json_codec)
219
+
(Json.Codec.list dhcp_lease_json_codec)
214
220
with
215
221
| Error e -> Error e
216
222
| Ok None -> Ok []
···
224
230
225
231
let lan_hosts_detailed http session_token =
226
232
match
227
-
get http session_token "/lan/browser/pub/" (Json.list lan_host_json_codec)
233
+
get http session_token "/lan/browser/pub/"
234
+
(Json.Codec.list lan_host_json_codec)
228
235
with
229
236
| Error e -> Error e
230
237
| Ok None -> Ok []
+1
-2
ocaml-freebox/lib/http.ml
+1
-2
ocaml-freebox/lib/http.ml
···
134
134
let decode codec s =
135
135
Result.map_error Json.Error.to_string (Json.of_string codec s)
136
136
137
-
let encode codec v =
138
-
match Json.to_string codec v with Ok s -> s | Error _ -> ""
137
+
let encode codec v = Json.to_string codec v
139
138
140
139
(** {1 API response wrapper} *)
141
140
+22
-18
ocaml-freebox/lib/parental.ml
+22
-18
ocaml-freebox/lib/parental.ml
···
31
31
| Unknown_mode s -> s
32
32
33
33
let filter_codec : filter Json.codec =
34
-
Json.Object.map ~kind:"filter"
34
+
Json.Codec.Object.map ~kind:"filter"
35
35
(fun id mac comment filter_mode forced_time current_mode macs ->
36
36
{
37
37
id = Option.value ~default:0 id;
···
44
44
filter_mode_of_string (Option.value ~default:"denied" current_mode);
45
45
macs = Option.value ~default:[] macs;
46
46
})
47
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (f : filter) -> Some f.id)
48
-
|> Json.Object.opt_mem "mac" Json.string ~enc:(fun (f : filter) ->
47
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int ~enc:(fun (f : filter) ->
48
+
Some f.id)
49
+
|> Json.Codec.Object.opt_mem "mac" Json.Codec.string ~enc:(fun (f : filter) ->
49
50
Some f.mac)
50
-
|> Json.Object.opt_mem "comment" Json.string ~enc:(fun (f : filter) ->
51
-
Some f.comment)
52
-
|> Json.Object.opt_mem "filter_mode" Json.string ~enc:(fun (f : filter) ->
53
-
Some (filter_mode_to_string f.filter_mode))
54
-
|> Json.Object.opt_mem "forced_time" Json.int ~enc:(fun (f : filter) ->
55
-
f.forced_time)
56
-
|> Json.Object.opt_mem "current_mode" Json.string ~enc:(fun (f : filter) ->
57
-
Some (filter_mode_to_string f.current_mode))
58
-
|> Json.Object.opt_mem "macs" (Json.list Json.string)
51
+
|> Json.Codec.Object.opt_mem "comment" Json.Codec.string
52
+
~enc:(fun (f : filter) -> Some f.comment)
53
+
|> Json.Codec.Object.opt_mem "filter_mode" Json.Codec.string
54
+
~enc:(fun (f : filter) -> Some (filter_mode_to_string f.filter_mode))
55
+
|> Json.Codec.Object.opt_mem "forced_time" Json.Codec.int
56
+
~enc:(fun (f : filter) -> f.forced_time)
57
+
|> Json.Codec.Object.opt_mem "current_mode" Json.Codec.string
58
+
~enc:(fun (f : filter) -> Some (filter_mode_to_string f.current_mode))
59
+
|> Json.Codec.Object.opt_mem "macs" (Json.Codec.list Json.Codec.string)
59
60
~enc:(fun (f : filter) -> Some f.macs)
60
-
|> Json.Object.skip_unknown |> Json.Object.finish
61
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
61
62
62
63
let config_codec : config Json.codec =
63
-
Json.Object.map ~kind:"parental_config" (fun default_filter_mode ->
64
+
Json.Codec.Object.map ~kind:"parental_config" (fun default_filter_mode ->
64
65
{
65
66
default_filter_mode =
66
67
filter_mode_of_string
67
68
(Option.value ~default:"allowed" default_filter_mode);
68
69
})
69
-
|> Json.Object.opt_mem "default_filter_mode" Json.string
70
+
|> Json.Codec.Object.opt_mem "default_filter_mode" Json.Codec.string
70
71
~enc:(fun (c : config) ->
71
72
Some (filter_mode_to_string c.default_filter_mode))
72
-
|> Json.Object.skip_unknown |> Json.Object.finish
73
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
73
74
74
75
(** {1 API functions} *)
75
76
···
85
86
86
87
let filters http ~clock cfg =
87
88
Auth.with_session http ~clock cfg (fun token ->
88
-
unwrap_list (get http token "/parental/filter/" (Json.list filter_codec)))
89
+
unwrap_list
90
+
(get http token "/parental/filter/" (Json.Codec.list filter_codec)))
89
91
90
92
let filter http ~clock cfg id =
91
93
Auth.with_session http ~clock cfg (fun token ->
···
95
97
let delete_filter http ~clock cfg id =
96
98
Auth.with_session http ~clock cfg (fun token ->
97
99
unwrap_unit
98
-
(delete http token (Fmt.str "/parental/filter/%d" id) (Json.null ())))
100
+
(delete http token
101
+
(Fmt.str "/parental/filter/%d" id)
102
+
(Json.Codec.null ())))
99
103
100
104
(** {1 Pretty printers} *)
101
105
+25
-25
ocaml-freebox/lib/switch.ml
+25
-25
ocaml-freebox/lib/switch.ml
···
40
40
| s -> Unknown_mode s
41
41
42
42
let port_status_codec : port_status Json.codec =
43
-
Json.Object.map ~kind:"port_status"
43
+
Json.Codec.Object.map ~kind:"port_status"
44
44
(fun
45
45
id
46
46
link
···
63
63
rx_packets_rate = Option.value ~default:0 rx_packets_rate;
64
64
tx_packets_rate = Option.value ~default:0 tx_packets_rate;
65
65
})
66
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (p : port_status) ->
67
-
Some p.id)
68
-
|> Json.Object.opt_mem "link" Json.bool ~enc:(fun (p : port_status) ->
69
-
Some p.link)
70
-
|> Json.Object.opt_mem "speed" Json.string ~enc:(fun (p : port_status) ->
71
-
Some p.speed)
72
-
|> Json.Object.opt_mem "duplex" Json.string ~enc:(fun (p : port_status) ->
73
-
Some p.duplex)
74
-
|> Json.Object.opt_mem "mode" Json.string ~enc:(fun (_ : port_status) ->
75
-
None)
76
-
|> Json.Object.opt_mem "rx_bytes_rate" Json.int
66
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int
67
+
~enc:(fun (p : port_status) -> Some p.id)
68
+
|> Json.Codec.Object.opt_mem "link" Json.Codec.bool
69
+
~enc:(fun (p : port_status) -> Some p.link)
70
+
|> Json.Codec.Object.opt_mem "speed" Json.Codec.string
71
+
~enc:(fun (p : port_status) -> Some p.speed)
72
+
|> Json.Codec.Object.opt_mem "duplex" Json.Codec.string
73
+
~enc:(fun (p : port_status) -> Some p.duplex)
74
+
|> Json.Codec.Object.opt_mem "mode" Json.Codec.string
75
+
~enc:(fun (_ : port_status) -> None)
76
+
|> Json.Codec.Object.opt_mem "rx_bytes_rate" Json.Codec.int
77
77
~enc:(fun (p : port_status) -> Some p.rx_bytes_rate)
78
-
|> Json.Object.opt_mem "tx_bytes_rate" Json.int
78
+
|> Json.Codec.Object.opt_mem "tx_bytes_rate" Json.Codec.int
79
79
~enc:(fun (p : port_status) -> Some p.tx_bytes_rate)
80
-
|> Json.Object.opt_mem "rx_packets_rate" Json.int
80
+
|> Json.Codec.Object.opt_mem "rx_packets_rate" Json.Codec.int
81
81
~enc:(fun (p : port_status) -> Some p.rx_packets_rate)
82
-
|> Json.Object.opt_mem "tx_packets_rate" Json.int
82
+
|> Json.Codec.Object.opt_mem "tx_packets_rate" Json.Codec.int
83
83
~enc:(fun (p : port_status) -> Some p.tx_packets_rate)
84
-
|> Json.Object.skip_unknown |> Json.Object.finish
84
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
85
85
86
86
let port_config_codec : port_config Json.codec =
87
-
Json.Object.map ~kind:"port_config" (fun id speed duplex ->
87
+
Json.Codec.Object.map ~kind:"port_config" (fun id speed duplex ->
88
88
{
89
89
id = Option.value ~default:0 id;
90
90
speed = Option.value ~default:"" speed;
91
91
duplex = Option.value ~default:"" duplex;
92
92
})
93
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (p : port_config) ->
94
-
Some p.id)
95
-
|> Json.Object.opt_mem "speed" Json.string ~enc:(fun (p : port_config) ->
96
-
Some p.speed)
97
-
|> Json.Object.opt_mem "duplex" Json.string ~enc:(fun (p : port_config) ->
98
-
Some p.duplex)
99
-
|> Json.Object.skip_unknown |> Json.Object.finish
93
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int
94
+
~enc:(fun (p : port_config) -> Some p.id)
95
+
|> Json.Codec.Object.opt_mem "speed" Json.Codec.string
96
+
~enc:(fun (p : port_config) -> Some p.speed)
97
+
|> Json.Codec.Object.opt_mem "duplex" Json.Codec.string
98
+
~enc:(fun (p : port_config) -> Some p.duplex)
99
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
100
100
101
101
(** {1 API functions} *)
102
102
103
103
let status http ~clock config =
104
104
with_session http ~clock config (fun token ->
105
105
unwrap_list
106
-
(get http token "/switch/status/" (Json.list port_status_codec)))
106
+
(get http token "/switch/status/" (Json.Codec.list port_status_codec)))
107
107
108
108
let port_status http ~clock config port_id =
109
109
with_session http ~clock config (fun token ->
+48
-41
ocaml-freebox/lib/system.ml
+48
-41
ocaml-freebox/lib/system.ml
···
37
37
(** {1 JSON codecs} *)
38
38
39
39
let sensor_codec : sensor Json.codec =
40
-
Json.Object.map ~kind:"sensor" (fun id name value ->
40
+
Json.Codec.Object.map ~kind:"sensor" (fun id name value ->
41
41
{
42
42
id = Option.value ~default:"" id;
43
43
name = Option.value ~default:"" name;
44
44
value = Option.value ~default:0 value;
45
45
})
46
-
|> Json.Object.opt_mem "id" Json.string ~enc:(fun (s : sensor) -> Some s.id)
47
-
|> Json.Object.opt_mem "name" Json.string ~enc:(fun (s : sensor) ->
48
-
Some s.name)
49
-
|> Json.Object.opt_mem "value" Json.int ~enc:(fun (s : sensor) ->
46
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.string ~enc:(fun (s : sensor) ->
47
+
Some s.id)
48
+
|> Json.Codec.Object.opt_mem "name" Json.Codec.string
49
+
~enc:(fun (s : sensor) -> Some s.name)
50
+
|> Json.Codec.Object.opt_mem "value" Json.Codec.int ~enc:(fun (s : sensor) ->
50
51
Some s.value)
51
-
|> Json.Object.skip_unknown |> Json.Object.finish
52
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
52
53
53
54
let disk_codec : disk Json.codec =
54
-
Json.Object.map ~kind:"disk"
55
+
Json.Codec.Object.map ~kind:"disk"
55
56
(fun id disk_type spinning state temp model serial total_bytes ->
56
57
{
57
58
id = Option.value ~default:0 id;
···
63
64
serial = Option.value ~default:"" serial;
64
65
total_bytes = Option.value ~default:0L total_bytes;
65
66
})
66
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (d : disk) -> Some d.id)
67
-
|> Json.Object.opt_mem "type" Json.string ~enc:(fun (d : disk) ->
67
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int ~enc:(fun (d : disk) ->
68
+
Some d.id)
69
+
|> Json.Codec.Object.opt_mem "type" Json.Codec.string ~enc:(fun (d : disk) ->
68
70
Some d.disk_type)
69
-
|> Json.Object.opt_mem "spinning" Json.bool ~enc:(fun (d : disk) ->
70
-
Some d.spinning)
71
-
|> Json.Object.opt_mem "state" Json.string ~enc:(fun (d : disk) ->
71
+
|> Json.Codec.Object.opt_mem "spinning" Json.Codec.bool
72
+
~enc:(fun (d : disk) -> Some d.spinning)
73
+
|> Json.Codec.Object.opt_mem "state" Json.Codec.string ~enc:(fun (d : disk) ->
72
74
Some d.state)
73
-
|> Json.Object.opt_mem "temp" Json.int ~enc:(fun (d : disk) -> d.temp)
74
-
|> Json.Object.opt_mem "model" Json.string ~enc:(fun (d : disk) ->
75
+
|> Json.Codec.Object.opt_mem "temp" Json.Codec.int ~enc:(fun (d : disk) ->
76
+
d.temp)
77
+
|> Json.Codec.Object.opt_mem "model" Json.Codec.string ~enc:(fun (d : disk) ->
75
78
Some d.model)
76
-
|> Json.Object.opt_mem "serial" Json.string ~enc:(fun (d : disk) ->
77
-
Some d.serial)
78
-
|> Json.Object.opt_mem "total_bytes" Json.int64 ~enc:(fun (d : disk) ->
79
-
Some d.total_bytes)
80
-
|> Json.Object.skip_unknown |> Json.Object.finish
79
+
|> Json.Codec.Object.opt_mem "serial" Json.Codec.string
80
+
~enc:(fun (d : disk) -> Some d.serial)
81
+
|> Json.Codec.Object.opt_mem "total_bytes" Json.Codec.int64
82
+
~enc:(fun (d : disk) -> Some d.total_bytes)
83
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
81
84
82
85
let info firmware_version mac serial uptime uptime_val board_name box_flavor
83
86
user_main_storage box_authenticated disk_status sensors fans disks =
···
98
101
}
99
102
100
103
let info_codec =
101
-
Json.Object.map ~kind:"system_info" info
102
-
|> Json.Object.opt_mem "firmware_version" Json.string ~enc:(fun i ->
103
-
Some i.firmware_version)
104
-
|> Json.Object.opt_mem "mac" Json.string ~enc:(fun i -> Some i.mac)
105
-
|> Json.Object.opt_mem "serial" Json.string ~enc:(fun i -> Some i.serial)
106
-
|> Json.Object.opt_mem "uptime" Json.string ~enc:(fun i -> Some i.uptime)
107
-
|> Json.Object.opt_mem "uptime_val" Json.int ~enc:(fun i ->
104
+
Json.Codec.Object.map ~kind:"system_info" info
105
+
|> Json.Codec.Object.opt_mem "firmware_version" Json.Codec.string
106
+
~enc:(fun i -> Some i.firmware_version)
107
+
|> Json.Codec.Object.opt_mem "mac" Json.Codec.string ~enc:(fun i ->
108
+
Some i.mac)
109
+
|> Json.Codec.Object.opt_mem "serial" Json.Codec.string ~enc:(fun i ->
110
+
Some i.serial)
111
+
|> Json.Codec.Object.opt_mem "uptime" Json.Codec.string ~enc:(fun i ->
112
+
Some i.uptime)
113
+
|> Json.Codec.Object.opt_mem "uptime_val" Json.Codec.int ~enc:(fun i ->
108
114
Some i.uptime_val)
109
-
|> Json.Object.opt_mem "board_name" Json.string ~enc:(fun i ->
115
+
|> Json.Codec.Object.opt_mem "board_name" Json.Codec.string ~enc:(fun i ->
110
116
Some i.board_name)
111
-
|> Json.Object.opt_mem "box_flavor" Json.string ~enc:(fun i ->
117
+
|> Json.Codec.Object.opt_mem "box_flavor" Json.Codec.string ~enc:(fun i ->
112
118
Some i.box_flavor)
113
-
|> Json.Object.opt_mem "user_main_storage" Json.string ~enc:(fun i ->
114
-
i.user_main_storage)
115
-
|> Json.Object.opt_mem "box_authenticated" Json.bool ~enc:(fun i ->
116
-
Some i.box_authenticated)
117
-
|> Json.Object.opt_mem "disk_status" Json.string ~enc:(fun i ->
119
+
|> Json.Codec.Object.opt_mem "user_main_storage" Json.Codec.string
120
+
~enc:(fun i -> i.user_main_storage)
121
+
|> Json.Codec.Object.opt_mem "box_authenticated" Json.Codec.bool
122
+
~enc:(fun i -> Some i.box_authenticated)
123
+
|> Json.Codec.Object.opt_mem "disk_status" Json.Codec.string ~enc:(fun i ->
118
124
Some i.disk_status)
119
-
|> Json.Object.opt_mem "sensors" (Json.list sensor_codec) ~enc:(fun i ->
120
-
Some i.sensors)
121
-
|> Json.Object.opt_mem "fans" (Json.list sensor_codec) ~enc:(fun i ->
122
-
Some i.fans)
123
-
|> Json.Object.opt_mem "disks" (Json.list disk_codec) ~enc:(fun i ->
124
-
Some i.disks)
125
-
|> Json.Object.skip_unknown |> Json.Object.finish
125
+
|> Json.Codec.Object.opt_mem "sensors" (Json.Codec.list sensor_codec)
126
+
~enc:(fun i -> Some i.sensors)
127
+
|> Json.Codec.Object.opt_mem "fans" (Json.Codec.list sensor_codec)
128
+
~enc:(fun i -> Some i.fans)
129
+
|> Json.Codec.Object.opt_mem "disks" (Json.Codec.list disk_codec)
130
+
~enc:(fun i -> Some i.disks)
131
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
126
132
127
133
(** {1 API functions} *)
128
134
···
134
140
let reboot http ~clock config =
135
141
with_session http ~clock config (fun token ->
136
142
unwrap_unit
137
-
(post http token "/system/reboot/" (Json.null ()) () (Json.null ())))
143
+
(post http token "/system/reboot/" (Json.Codec.null ()) ()
144
+
(Json.Codec.null ())))
138
145
139
146
(** {1 Pretty printers} *)
140
147
+63
-59
ocaml-freebox/lib/wifi.ml
+63
-59
ocaml-freebox/lib/wifi.ml
···
40
40
(** {1 JSON codecs} *)
41
41
42
42
let config_codec : config Json.codec =
43
-
Json.Object.map ~kind:"config" (fun enabled mac_filter_state ->
43
+
Json.Codec.Object.map ~kind:"config" (fun enabled mac_filter_state ->
44
44
{
45
45
enabled = Option.value ~default:false enabled;
46
46
mac_filter_state = Option.value ~default:"disabled" mac_filter_state;
47
47
})
48
-
|> Json.Object.opt_mem "enabled" Json.bool ~enc:(fun (c : config) ->
49
-
Some c.enabled)
50
-
|> Json.Object.opt_mem "mac_filter_state" Json.string
48
+
|> Json.Codec.Object.opt_mem "enabled" Json.Codec.bool
49
+
~enc:(fun (c : config) -> Some c.enabled)
50
+
|> Json.Codec.Object.opt_mem "mac_filter_state" Json.Codec.string
51
51
~enc:(fun (c : config) -> Some c.mac_filter_state)
52
-
|> Json.Object.skip_unknown |> Json.Object.finish
52
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
53
53
54
54
let ap_config_codec : ap_config Json.codec =
55
-
Json.Object.map ~kind:"ap_config" (fun id name enabled channel ht_mode ->
55
+
Json.Codec.Object.map ~kind:"ap_config"
56
+
(fun id name enabled channel ht_mode ->
56
57
{
57
58
id = Option.value ~default:0 id;
58
59
name = Option.value ~default:"" name;
···
60
61
channel = Option.value ~default:0 channel;
61
62
ht_mode = Option.value ~default:"" ht_mode;
62
63
})
63
-
|> Json.Object.opt_mem "id" Json.int ~enc:(fun (c : ap_config) -> Some c.id)
64
-
|> Json.Object.opt_mem "name" Json.string ~enc:(fun (c : ap_config) ->
65
-
Some c.name)
66
-
|> Json.Object.opt_mem "enabled" Json.bool ~enc:(fun (c : ap_config) ->
67
-
Some c.enabled)
68
-
|> Json.Object.opt_mem "channel" Json.int ~enc:(fun (c : ap_config) ->
69
-
Some c.channel)
70
-
|> Json.Object.opt_mem "ht_mode" Json.string ~enc:(fun (c : ap_config) ->
71
-
Some c.ht_mode)
72
-
|> Json.Object.skip_unknown |> Json.Object.finish
64
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.int ~enc:(fun (c : ap_config) ->
65
+
Some c.id)
66
+
|> Json.Codec.Object.opt_mem "name" Json.Codec.string
67
+
~enc:(fun (c : ap_config) -> Some c.name)
68
+
|> Json.Codec.Object.opt_mem "enabled" Json.Codec.bool
69
+
~enc:(fun (c : ap_config) -> Some c.enabled)
70
+
|> Json.Codec.Object.opt_mem "channel" Json.Codec.int
71
+
~enc:(fun (c : ap_config) -> Some c.channel)
72
+
|> Json.Codec.Object.opt_mem "ht_mode" Json.Codec.string
73
+
~enc:(fun (c : ap_config) -> Some c.ht_mode)
74
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
73
75
74
76
let bss_config_codec : bss_config Json.codec =
75
-
Json.Object.map ~kind:"bss_config"
77
+
Json.Codec.Object.map ~kind:"bss_config"
76
78
(fun id phy_id enabled ssid hide_ssid encryption ->
77
79
{
78
80
id = Option.value ~default:"" id;
···
82
84
hide_ssid = Option.value ~default:false hide_ssid;
83
85
encryption = Option.value ~default:"" encryption;
84
86
})
85
-
|> Json.Object.opt_mem "id" Json.string ~enc:(fun (c : bss_config) ->
86
-
Some c.id)
87
-
|> Json.Object.opt_mem "phy_id" Json.int ~enc:(fun (c : bss_config) ->
88
-
Some c.phy_id)
89
-
|> Json.Object.opt_mem "enabled" Json.bool ~enc:(fun (c : bss_config) ->
90
-
Some c.enabled)
91
-
|> Json.Object.opt_mem "ssid" Json.string ~enc:(fun (c : bss_config) ->
92
-
Some c.ssid)
93
-
|> Json.Object.opt_mem "hide_ssid" Json.bool ~enc:(fun (c : bss_config) ->
94
-
Some c.hide_ssid)
95
-
|> Json.Object.opt_mem "encryption" Json.string
87
+
|> Json.Codec.Object.opt_mem "id" Json.Codec.string
88
+
~enc:(fun (c : bss_config) -> Some c.id)
89
+
|> Json.Codec.Object.opt_mem "phy_id" Json.Codec.int
90
+
~enc:(fun (c : bss_config) -> Some c.phy_id)
91
+
|> Json.Codec.Object.opt_mem "enabled" Json.Codec.bool
92
+
~enc:(fun (c : bss_config) -> Some c.enabled)
93
+
|> Json.Codec.Object.opt_mem "ssid" Json.Codec.string
94
+
~enc:(fun (c : bss_config) -> Some c.ssid)
95
+
|> Json.Codec.Object.opt_mem "hide_ssid" Json.Codec.bool
96
+
~enc:(fun (c : bss_config) -> Some c.hide_ssid)
97
+
|> Json.Codec.Object.opt_mem "encryption" Json.Codec.string
96
98
~enc:(fun (c : bss_config) -> Some c.encryption)
97
-
|> Json.Object.skip_unknown |> Json.Object.finish
99
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
98
100
99
101
let station_codec : station Json.codec =
100
-
Json.Object.map ~kind:"station"
102
+
Json.Codec.Object.map ~kind:"station"
101
103
(fun mac bssid hostname signal rx_rate tx_rate inactive conn_duration ->
102
104
{
103
105
mac = Option.value ~default:"" mac;
···
109
111
inactive = Option.value ~default:0 inactive;
110
112
conn_duration = Option.value ~default:0 conn_duration;
111
113
})
112
-
|> Json.Object.opt_mem "mac" Json.string ~enc:(fun (s : station) ->
113
-
Some s.mac)
114
-
|> Json.Object.opt_mem "bssid" Json.string ~enc:(fun (s : station) ->
115
-
Some s.bssid)
116
-
|> Json.Object.opt_mem "hostname" Json.string ~enc:(fun (s : station) ->
117
-
s.hostname)
118
-
|> Json.Object.opt_mem "signal" Json.int ~enc:(fun (s : station) ->
119
-
Some s.signal)
120
-
|> Json.Object.opt_mem "rx_rate" Json.int ~enc:(fun (s : station) ->
121
-
Some s.rx_rate)
122
-
|> Json.Object.opt_mem "tx_rate" Json.int ~enc:(fun (s : station) ->
123
-
Some s.tx_rate)
124
-
|> Json.Object.opt_mem "inactive" Json.int ~enc:(fun (s : station) ->
125
-
Some s.inactive)
126
-
|> Json.Object.opt_mem "conn_duration" Json.int ~enc:(fun (s : station) ->
127
-
Some s.conn_duration)
128
-
|> Json.Object.skip_unknown |> Json.Object.finish
114
+
|> Json.Codec.Object.opt_mem "mac" Json.Codec.string
115
+
~enc:(fun (s : station) -> Some s.mac)
116
+
|> Json.Codec.Object.opt_mem "bssid" Json.Codec.string
117
+
~enc:(fun (s : station) -> Some s.bssid)
118
+
|> Json.Codec.Object.opt_mem "hostname" Json.Codec.string
119
+
~enc:(fun (s : station) -> s.hostname)
120
+
|> Json.Codec.Object.opt_mem "signal" Json.Codec.int
121
+
~enc:(fun (s : station) -> Some s.signal)
122
+
|> Json.Codec.Object.opt_mem "rx_rate" Json.Codec.int
123
+
~enc:(fun (s : station) -> Some s.rx_rate)
124
+
|> Json.Codec.Object.opt_mem "tx_rate" Json.Codec.int
125
+
~enc:(fun (s : station) -> Some s.tx_rate)
126
+
|> Json.Codec.Object.opt_mem "inactive" Json.Codec.int
127
+
~enc:(fun (s : station) -> Some s.inactive)
128
+
|> Json.Codec.Object.opt_mem "conn_duration" Json.Codec.int
129
+
~enc:(fun (s : station) -> Some s.conn_duration)
130
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
129
131
130
132
let mac_filter_codec : mac_filter Json.codec =
131
-
Json.Object.map ~kind:"mac_filter" (fun mac comment host_type ->
133
+
Json.Codec.Object.map ~kind:"mac_filter" (fun mac comment host_type ->
132
134
{
133
135
mac = Option.value ~default:"" mac;
134
136
comment = Option.value ~default:"" comment;
135
137
host_type = Option.value ~default:"" host_type;
136
138
})
137
-
|> Json.Object.opt_mem "mac" Json.string ~enc:(fun (f : mac_filter) ->
138
-
Some f.mac)
139
-
|> Json.Object.opt_mem "comment" Json.string ~enc:(fun (f : mac_filter) ->
140
-
Some f.comment)
141
-
|> Json.Object.opt_mem "host_type" Json.string ~enc:(fun (f : mac_filter) ->
142
-
Some f.host_type)
143
-
|> Json.Object.skip_unknown |> Json.Object.finish
139
+
|> Json.Codec.Object.opt_mem "mac" Json.Codec.string
140
+
~enc:(fun (f : mac_filter) -> Some f.mac)
141
+
|> Json.Codec.Object.opt_mem "comment" Json.Codec.string
142
+
~enc:(fun (f : mac_filter) -> Some f.comment)
143
+
|> Json.Codec.Object.opt_mem "host_type" Json.Codec.string
144
+
~enc:(fun (f : mac_filter) -> Some f.host_type)
145
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
144
146
145
147
(** {1 API functions} *)
146
148
···
157
159
158
160
let access_points http ~clock config =
159
161
with_session http ~clock config (fun token ->
160
-
unwrap_list (get http token "/wifi/ap/" (Json.list ap_config_codec)))
162
+
unwrap_list (get http token "/wifi/ap/" (Json.Codec.list ap_config_codec)))
161
163
162
164
let bss_list http ~clock config =
163
165
with_session http ~clock config (fun token ->
164
-
unwrap_list (get http token "/wifi/bss/" (Json.list bss_config_codec)))
166
+
unwrap_list
167
+
(get http token "/wifi/bss/" (Json.Codec.list bss_config_codec)))
165
168
166
169
let stations http ~clock config =
167
170
with_session http ~clock config (fun token ->
168
-
unwrap_list (get http token "/wifi/stations/" (Json.list station_codec)))
171
+
unwrap_list
172
+
(get http token "/wifi/stations/" (Json.Codec.list station_codec)))
169
173
170
174
let mac_filters http ~clock config =
171
175
with_session http ~clock config (fun token ->
172
176
unwrap_list
173
-
(get http token "/wifi/mac_filter/" (Json.list mac_filter_codec)))
177
+
(get http token "/wifi/mac_filter/" (Json.Codec.list mac_filter_codec)))
174
178
175
179
(** {1 Pretty printers} *)
176
180
-1
ocaml-fsr/c/dune
-1
ocaml-fsr/c/dune
-1
ocaml-fsr/fuzz/dune
-1
ocaml-fsr/fuzz/dune
-1
ocaml-gauth/lib/dune
-1
ocaml-gauth/lib/dune
+25
-20
ocaml-gauth/lib/gauth.ml
+25
-20
ocaml-gauth/lib/gauth.ml
···
12
12
let err_sa_expected_rsa () = err_msg "service-account key must be RSA"
13
13
let err_sa_wrong_type t = err_msg "expected type=service_account, got %S" t
14
14
let err_sa_pem m = err_msg "failed to decode private_key PEM: %s" m
15
-
let err_sa_json e = err_msg "service-account JSON parse: %s" e
15
+
16
+
let err_sa_json e =
17
+
err_msg "service-account JSON parse: %s" (Json.Error.to_string e)
18
+
16
19
let err_io e = err_msg "%s" (Printexc.to_string e)
17
20
let err_jwt_sign e = err_msg "JWT sign: %s" (Jwt.error_to_string e)
18
21
···
93
96
}
94
97
95
98
let raw_jsont =
96
-
Json.Object.map ~kind:"service_account"
99
+
Json.Codec.Object.map ~kind:"service_account"
97
100
(fun type_ client_email token_uri private_key private_key_id ->
98
101
{ type_; client_email; token_uri; private_key; private_key_id })
99
-
|> Json.Object.mem "type" Json.string ~enc:(fun k -> k.type_)
100
-
|> Json.Object.mem "client_email" Json.string ~enc:(fun k ->
102
+
|> Json.Codec.Object.mem "type" Json.Codec.string ~enc:(fun k -> k.type_)
103
+
|> Json.Codec.Object.mem "client_email" Json.Codec.string ~enc:(fun k ->
101
104
k.client_email)
102
-
|> Json.Object.opt_mem "token_uri" Json.string ~enc:(fun k -> k.token_uri)
103
-
|> Json.Object.mem "private_key" Json.string ~enc:(fun k -> k.private_key)
104
-
|> Json.Object.opt_mem "private_key_id" Json.string ~enc:(fun k ->
105
-
k.private_key_id)
106
-
|> Json.Object.skip_unknown |> Json.Object.finish
105
+
|> Json.Codec.Object.opt_mem "token_uri" Json.Codec.string ~enc:(fun k ->
106
+
k.token_uri)
107
+
|> Json.Codec.Object.mem "private_key" Json.Codec.string ~enc:(fun k ->
108
+
k.private_key)
109
+
|> Json.Codec.Object.opt_mem "private_key_id" Json.Codec.string
110
+
~enc:(fun k -> k.private_key_id)
111
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
107
112
108
113
(* Convert X509 RSA private key to a Jwt.Jwk RSA private key.
109
114
JWK RFC 7518 §6.3 requires the RSA components as unsigned big-endian
···
141
146
| Ok _ -> err_sa_expected_rsa ()
142
147
143
148
let of_json s =
144
-
match Json_bytesrw.decode_string raw_jsont s with
149
+
match Json.of_string raw_jsont s with
145
150
| Error e -> err_sa_json e
146
151
| Ok r -> of_raw r
147
152
···
433
438
}
434
439
435
440
let snapshot_jsont =
436
-
Json.Object.map ~kind:"gauth_token"
441
+
Json.Codec.Object.map ~kind:"gauth_token"
437
442
(fun access_token refresh_token expires_at ->
438
443
{ access_token; refresh_token; expires_at })
439
-
|> Json.Object.mem "access_token" Json.string ~enc:(fun s -> s.access_token)
440
-
|> Json.Object.opt_mem "refresh_token" Json.string ~enc:(fun s ->
444
+
|> Json.Codec.Object.mem "access_token" Json.Codec.string ~enc:(fun s ->
445
+
s.access_token)
446
+
|> Json.Codec.Object.opt_mem "refresh_token" Json.Codec.string ~enc:(fun s ->
441
447
s.refresh_token)
442
-
|> Json.Object.opt_mem "expires_at" Json.number ~enc:(fun s -> s.expires_at)
443
-
|> Json.Object.skip_unknown |> Json.Object.finish
448
+
|> Json.Codec.Object.opt_mem "expires_at" Json.Codec.number ~enc:(fun s ->
449
+
s.expires_at)
450
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
444
451
445
452
let snapshot_of_token = function
446
453
| Oauth_token t ->
···
458
465
459
466
let to_json t =
460
467
let s = snapshot_of_token t in
461
-
match Json_bytesrw.encode_string snapshot_jsont s with
462
-
| Ok s -> s
463
-
| Error e -> Fmt.failwith "Gauth.to_json: %s" e
468
+
Json.to_string snapshot_jsont s
464
469
465
470
let of_json http ~clock ~client_id ~client_secret body =
466
-
match Json_bytesrw.decode_string snapshot_jsont body with
467
-
| Error e -> Error (`Msg e)
471
+
match Json.of_string snapshot_jsont body with
472
+
| Error e -> Error (`Msg (Json.Error.to_string e))
468
473
| Ok s ->
469
474
let tok =
470
475
Oauth.Token.make http Oauth.Google ~client_id ~client_secret ~clock
+29
-24
ocaml-gdocs/lib/comments.ml
+29
-24
ocaml-gdocs/lib/comments.ml
···
5
5
module Log = (val Logs.src_log src : Logs.LOG)
6
6
7
7
let err_msg fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
8
-
let err_json_decode e = err_msg "comments JSON decode: %s" e
8
+
9
+
let err_json_decode e =
10
+
err_msg "comments JSON decode: %s" (Json.Error.to_string e)
11
+
9
12
let err_http status body = err_msg "Drive comments HTTP %d: %s" status body
10
13
let scope = "https://www.googleapis.com/auth/drive.readonly"
11
14
···
37
40
type raw_author = { display_name : string }
38
41
39
42
let author_jsont =
40
-
Json.Object.map ~kind:"author" (fun display_name -> { display_name })
41
-
|> Json.Object.mem "displayName" Json.string ~dec_absent:"" ~enc:(fun a ->
42
-
a.display_name)
43
-
|> Json.Object.skip_unknown |> Json.Object.finish
43
+
Json.Codec.Object.map ~kind:"author" (fun display_name -> { display_name })
44
+
|> Json.Codec.Object.mem "displayName" Json.Codec.string ~dec_absent:""
45
+
~enc:(fun a -> a.display_name)
46
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
44
47
45
48
type raw_quoted = { value : string }
46
49
47
50
let quoted_jsont =
48
-
Json.Object.map ~kind:"quotedFileContent" (fun value -> { value })
49
-
|> Json.Object.mem "value" Json.string ~dec_absent:"" ~enc:(fun q ->
50
-
q.value)
51
-
|> Json.Object.skip_unknown |> Json.Object.finish
51
+
Json.Codec.Object.map ~kind:"quotedFileContent" (fun value -> { value })
52
+
|> Json.Codec.Object.mem "value" Json.Codec.string ~dec_absent:""
53
+
~enc:(fun q -> q.value)
54
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
52
55
53
56
let comment_jsont =
54
-
Json.Object.map ~kind:"comment"
57
+
Json.Codec.Object.map ~kind:"comment"
55
58
(fun id author content quoted anchor resolved ->
56
59
{
57
60
id;
···
61
64
anchor;
62
65
resolved;
63
66
})
64
-
|> Json.Object.mem "id" Json.string ~enc:(fun c -> c.id)
65
-
|> Json.Object.opt_mem "author" author_jsont ~enc:(fun _ -> None)
66
-
|> Json.Object.mem "content" Json.string ~dec_absent:"" ~enc:(fun c ->
67
-
c.content)
68
-
|> Json.Object.opt_mem "quotedFileContent" quoted_jsont ~enc:(fun _ -> None)
69
-
|> Json.Object.opt_mem "anchor" Json.string ~enc:(fun c -> c.anchor)
70
-
|> Json.Object.mem "resolved" Json.bool ~dec_absent:false ~enc:(fun c ->
71
-
c.resolved)
72
-
|> Json.Object.skip_unknown |> Json.Object.finish
67
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun c -> c.id)
68
+
|> Json.Codec.Object.opt_mem "author" author_jsont ~enc:(fun _ -> None)
69
+
|> Json.Codec.Object.mem "content" Json.Codec.string ~dec_absent:""
70
+
~enc:(fun c -> c.content)
71
+
|> Json.Codec.Object.opt_mem "quotedFileContent" quoted_jsont ~enc:(fun _ ->
72
+
None)
73
+
|> Json.Codec.Object.opt_mem "anchor" Json.Codec.string ~enc:(fun c ->
74
+
c.anchor)
75
+
|> Json.Codec.Object.mem "resolved" Json.Codec.bool ~dec_absent:false
76
+
~enc:(fun c -> c.resolved)
77
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
73
78
74
79
type raw_list = { comments : t list }
75
80
76
81
let list_jsont =
77
-
Json.Object.map ~kind:"comment_list" (fun comments -> { comments })
78
-
|> Json.Object.mem "comments" (Json.list comment_jsont) ~dec_absent:[]
79
-
~enc:(fun r -> r.comments)
80
-
|> Json.Object.skip_unknown |> Json.Object.finish
82
+
Json.Codec.Object.map ~kind:"comment_list" (fun comments -> { comments })
83
+
|> Json.Codec.Object.mem "comments" (Json.Codec.list comment_jsont)
84
+
~dec_absent:[] ~enc:(fun r -> r.comments)
85
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
81
86
82
87
let of_json_string body =
83
-
match Json_bytesrw.decode_string list_jsont body with
88
+
match Json.of_string list_jsont body with
84
89
| Error e -> err_json_decode e
85
90
| Ok r -> Ok r.comments
86
91
+4
-4
ocaml-gdocs/lib/document.ml
+4
-4
ocaml-gdocs/lib/document.ml
···
1
1
(** A parsed Google Docs document. *)
2
2
3
3
let err_msg fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
4
-
let err_json_decode e = err_msg "JSON decode: %s" e
4
+
let err_json_decode e = err_msg "JSON decode: %s" (Json.Error.to_string e)
5
5
6
6
type t = { document_id : string; title : string; raw : string }
7
7
···
27
27
so we just concatenate -- no manual newline insertion (which would
28
28
double-space the output). *)
29
29
let extract_text value =
30
-
let open Jsont in
30
+
let open Json in
31
31
let buf = Buffer.create 1024 in
32
32
let rec walk_root = function
33
33
| Object (members, _) ->
···
108
108
| _ -> ""
109
109
110
110
let of_json_string body =
111
-
match Json_bytesrw.decode_string Json.json body with
111
+
match Json.Value.of_string body with
112
112
| Error e -> err_json_decode e
113
113
| Ok json ->
114
114
let document_id = top_string json "documentId" in
···
116
116
Ok { document_id; title; raw = body }
117
117
118
118
let to_text d =
119
-
match Json_bytesrw.decode_string Json.json d.raw with
119
+
match Json.Value.of_string d.raw with
120
120
| Error _ -> ""
121
121
| Ok json -> extract_text json
-1
ocaml-gdocs/lib/dune
-1
ocaml-gdocs/lib/dune
+1
-1
ocaml-gdocs/lib/markdown.ml
+1
-1
ocaml-gdocs/lib/markdown.ml
+7
-8
ocaml-gdocs/lib/store.ml
+7
-8
ocaml-gdocs/lib/store.ml
···
12
12
type client = { client_id : string; client_secret : string }
13
13
14
14
let client_jsont =
15
-
Json.Object.map ~kind:"gdocs_client" (fun client_id client_secret ->
15
+
Json.Codec.Object.map ~kind:"gdocs_client" (fun client_id client_secret ->
16
16
{ client_id; client_secret })
17
-
|> Json.Object.mem "client_id" Json.string ~enc:(fun c -> c.client_id)
18
-
|> Json.Object.mem "client_secret" Json.string ~enc:(fun c ->
17
+
|> Json.Codec.Object.mem "client_id" Json.Codec.string ~enc:(fun c ->
18
+
c.client_id)
19
+
|> Json.Codec.Object.mem "client_secret" Json.Codec.string ~enc:(fun c ->
19
20
c.client_secret)
20
-
|> Json.Object.skip_unknown |> Json.Object.finish
21
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
21
22
22
23
let save_file path data =
23
24
Eio.Path.save ~create:(`Or_truncate 0o600) path data;
···
29
30
if Eio.Path.is_file path then Some (Eio.Path.load path) else None
30
31
31
32
let save_client fs c =
32
-
match Json_bytesrw.encode_string client_jsont c with
33
-
| Ok s -> save_file (client_path fs) s
34
-
| Error e -> Fmt.failwith "encode client: %s" e
33
+
save_file (client_path fs) (Json.to_string client_jsont c)
35
34
36
35
let load_client fs =
37
36
match load_file (client_path fs) with
38
37
| None -> None
39
38
| Some body -> (
40
-
match Json_bytesrw.decode_string client_jsont body with
39
+
match Json.of_string client_jsont body with
41
40
| Ok c -> Some c
42
41
| Error _ -> None)
43
42
-1
ocaml-git/fuzz/dune
-1
ocaml-git/fuzz/dune
-1
ocaml-git/test/test_index.ml
-1
ocaml-git/test/test_index.ml
-1
ocaml-globe/fuzz/dune
-1
ocaml-globe/fuzz/dune
-1
ocaml-gpt/c/dune
-1
ocaml-gpt/c/dune
-1
ocaml-gpt/fuzz/dune
-1
ocaml-gpt/fuzz/dune
+1
-2
ocaml-gpt/lib/dune
+1
-2
ocaml-gpt/lib/dune
+4
-11
ocaml-gpt/test/test_gpt.ml
+4
-11
ocaml-gpt/test/test_gpt.ml
···
226
226
in
227
227
let partition_table_len = String.length partition_table_str in
228
228
match Gpt.of_string header_str ~sector_size:512 with
229
-
| Error e ->
230
-
Alcotest.failf "Failed to parse marshalled gpt header: %s"
231
-
e
229
+
| Error e -> Alcotest.failf "Failed to parse marshalled gpt header: %s" e
232
230
| Ok (`Read_partition_table (_lba, sectors), k) -> (
233
231
Fmt.pr "expected %d, got %d\n%!" (partition_table_len / 512) sectors;
234
232
Alcotest.(check int)
···
237
235
sectors;
238
236
match k (Bytes.of_string partition_table_str) with
239
237
| Error e ->
240
-
Alcotest.failf "Failed to parse marshalled partition table: %s"
241
-
e
238
+
Alcotest.failf "Failed to parse marshalled partition table: %s" e
242
239
| Ok unmarshalled ->
243
240
Alcotest.check gpt "unmarshalled equal to original" morig unmarshalled
244
241
)
···
539
536
| Error e -> Alcotest.failf "header parse failed: %s" e
540
537
| Ok (`Read_partition_table (_, _), k) -> (
541
538
match k (Bytes.of_string pt_str) with
542
-
| Error e ->
543
-
Alcotest.failf "partition table parse failed: %s"
544
-
e
539
+
| Error e -> Alcotest.failf "partition table parse failed: %s" e
545
540
| Ok gpt' ->
546
541
Alcotest.(check int32)
547
542
"header_crc32 preserved" gpt.Gpt.header_crc32 gpt'.Gpt.header_crc32;
···
599
594
Alcotest.(check int64)
600
595
"partition starts at first_usable_lba" fula
601
596
(List.hd gpt.Gpt.partitions).Gpt.Partition.starting_lba
602
-
| Error e ->
603
-
Alcotest.failf "partition at first_usable_lba should work: %s"
604
-
e
597
+
| Error e -> Alcotest.failf "partition at first_usable_lba should work: %s" e
605
598
606
599
let first_usable_lba_test_collection =
607
600
[
-1
ocaml-hap/fuzz/dune
-1
ocaml-hap/fuzz/dune
-1
ocaml-hap/lib/dune
-1
ocaml-hap/lib/dune
+52
-58
ocaml-hap/lib/hap.ml
+52
-58
ocaml-hap/lib/hap.ml
···
536
536
let pos = Re.Group.stop g 0 in
537
537
let body = String.sub decrypted pos (String.length decrypted - pos) in
538
538
Result.map_error
539
-
(fun e -> `Msg e)
540
-
(Json_bytesrw.decode_string Json.json body)
539
+
(fun e -> `Msg (Json.Error.to_string e))
540
+
(Json.Value.of_string body)
541
541
542
542
(* Get accessories from a session *)
543
543
let accessories ~net ~sw session =
···
553
553
type char_write = { cw_aid : int; cw_iid : int; cw_value : Json.t }
554
554
555
555
let char_write_codec =
556
-
Json.Object.map ~kind:"char_write" (fun aid iid value ->
556
+
Json.Codec.Object.map ~kind:"char_write" (fun aid iid value ->
557
557
{ cw_aid = aid; cw_iid = iid; cw_value = value })
558
-
|> Json.Object.mem "aid" Json.int ~enc:(fun c -> c.cw_aid)
559
-
|> Json.Object.mem "iid" Json.int ~enc:(fun c -> c.cw_iid)
560
-
|> Json.Object.mem "value" Json.json ~enc:(fun c -> c.cw_value)
561
-
|> Json.Object.finish
558
+
|> Json.Codec.Object.mem "aid" Json.Codec.int ~enc:(fun c -> c.cw_aid)
559
+
|> Json.Codec.Object.mem "iid" Json.Codec.int ~enc:(fun c -> c.cw_iid)
560
+
|> Json.Codec.Object.mem "value" Json.Codec.Value.t ~enc:(fun c -> c.cw_value)
561
+
|> Json.Codec.Object.finish
562
562
563
563
type char_write_request = { characteristics : char_write list }
564
564
565
565
let char_write_request_codec =
566
-
Json.Object.map ~kind:"char_write_request" (fun characteristics ->
566
+
Json.Codec.Object.map ~kind:"char_write_request" (fun characteristics ->
567
567
{ characteristics })
568
-
|> Json.Object.mem "characteristics" (Json.list char_write_codec)
568
+
|> Json.Codec.Object.mem "characteristics" (Json.Codec.list char_write_codec)
569
569
~enc:(fun r -> r.characteristics)
570
-
|> Json.Object.finish
570
+
|> Json.Codec.Object.finish
571
571
572
572
(* Write a characteristic *)
573
573
let put_characteristic ~net ~sw session ~aid ~iid value =
574
574
let req =
575
575
{ characteristics = [ { cw_aid = aid; cw_iid = iid; cw_value = value } ] }
576
576
in
577
-
let body =
578
-
match Json_bytesrw.encode_string char_write_request_codec req with
579
-
| Ok s -> s
580
-
| Error _ -> "{}"
581
-
in
577
+
let body = Json.to_string char_write_request_codec req in
582
578
let path = "/characteristics" in
583
579
let req =
584
580
Fmt.str
···
632
628
}
633
629
634
630
let stored =
635
-
Json.Object.map ~kind:"hap.pairing"
631
+
Json.Codec.Object.map ~kind:"hap.pairing"
636
632
(fun
637
633
accessory_id
638
634
accessory_ltpk
···
647
643
controller_ltsk;
648
644
controller_ltpk;
649
645
})
650
-
|> Json.Object.mem "accessory_id" Json.string ~enc:(fun p ->
646
+
|> Json.Codec.Object.mem "accessory_id" Json.Codec.string ~enc:(fun p ->
651
647
p.accessory_id)
652
-
|> Json.Object.mem "accessory_ltpk" Json.string ~enc:(fun p ->
648
+
|> Json.Codec.Object.mem "accessory_ltpk" Json.Codec.string ~enc:(fun p ->
653
649
p.accessory_ltpk)
654
-
|> Json.Object.mem "controller_id" Json.string ~enc:(fun p ->
650
+
|> Json.Codec.Object.mem "controller_id" Json.Codec.string ~enc:(fun p ->
655
651
p.controller_id)
656
-
|> Json.Object.mem "controller_ltsk" Json.string ~enc:(fun p ->
652
+
|> Json.Codec.Object.mem "controller_ltsk" Json.Codec.string ~enc:(fun p ->
657
653
p.controller_ltsk)
658
-
|> Json.Object.mem "controller_ltpk" Json.string ~enc:(fun p ->
654
+
|> Json.Codec.Object.mem "controller_ltpk" Json.Codec.string ~enc:(fun p ->
659
655
p.controller_ltpk)
660
-
|> Json.Object.finish
656
+
|> Json.Codec.Object.finish
661
657
662
658
let of_pairing (p : pairing) : stored =
663
659
{
···
681
677
(* Save/load pairing to file *)
682
678
let save_pairing ~fs ~path (pairing : pairing) =
683
679
let stored = Pairing_json.of_pairing pairing in
684
-
match
685
-
Json_bytesrw.encode_string ~format:Json.Indent Pairing_json.stored stored
686
-
with
680
+
match Json.to_string ~format:Json.Indent Pairing_json.stored stored with
687
681
| Ok json ->
688
682
Eio.Path.save ~create:(`Or_truncate 0o600) Eio.Path.(fs / path) json
689
683
| Error _ -> ()
···
694
688
else
695
689
begin try
696
690
let content = Eio.Path.load full_path in
697
-
match Json_bytesrw.decode_string Pairing_json.stored content with
691
+
match Json.of_string Pairing_json.stored content with
698
692
| Ok stored -> Some (Pairing_json.to_pairing stored)
699
693
| Error _ -> None
700
694
with Eio.Io _ -> None
···
862
856
(** HAP characteristic *)
863
857
864
858
let characteristic =
865
-
Json.Object.map ~kind:"hap.characteristic" (fun iid type_ value ->
859
+
Json.Codec.Object.map ~kind:"hap.characteristic" (fun iid type_ value ->
866
860
{ iid; type_; value })
867
-
|> Json.Object.mem "iid" Json.int ~enc:(fun c -> c.iid)
868
-
|> Json.Object.mem "type" Json.string ~enc:(fun c -> c.type_)
869
-
|> Json.Object.opt_mem "value" Json.json ~enc:(fun c -> c.value)
870
-
|> Json.Object.finish
861
+
|> Json.Codec.Object.mem "iid" Json.Codec.int ~enc:(fun c -> c.iid)
862
+
|> Json.Codec.Object.mem "type" Json.Codec.string ~enc:(fun c -> c.type_)
863
+
|> Json.Codec.Object.opt_mem "value" Json.Codec.Value.t ~enc:(fun c ->
864
+
c.value)
865
+
|> Json.Codec.Object.finish
871
866
872
867
type service = {
873
868
iid : int;
···
877
872
(** HAP service *)
878
873
879
874
let service =
880
-
Json.Object.map ~kind:"hap.service" (fun iid type_ characteristics ->
875
+
Json.Codec.Object.map ~kind:"hap.service" (fun iid type_ characteristics ->
881
876
{ iid; type_; characteristics })
882
-
|> Json.Object.mem "iid" Json.int ~enc:(fun s -> s.iid)
883
-
|> Json.Object.mem "type" Json.string ~enc:(fun s -> s.type_)
884
-
|> Json.Object.mem "characteristics" (Json.list characteristic)
877
+
|> Json.Codec.Object.mem "iid" Json.Codec.int ~enc:(fun s -> s.iid)
878
+
|> Json.Codec.Object.mem "type" Json.Codec.string ~enc:(fun s -> s.type_)
879
+
|> Json.Codec.Object.mem "characteristics" (Json.Codec.list characteristic)
885
880
~enc:(fun s -> s.characteristics)
886
-
|> Json.Object.finish
881
+
|> Json.Codec.Object.finish
887
882
888
883
type accessory = { aid : int; services : service list }
889
884
(** HAP accessory *)
890
885
891
886
let accessory =
892
-
Json.Object.map ~kind:"hap.accessory" (fun aid services ->
887
+
Json.Codec.Object.map ~kind:"hap.accessory" (fun aid services ->
893
888
{ aid; services })
894
-
|> Json.Object.mem "aid" Json.int ~enc:(fun a -> a.aid)
895
-
|> Json.Object.mem "services" (Json.list service) ~enc:(fun a ->
889
+
|> Json.Codec.Object.mem "aid" Json.Codec.int ~enc:(fun a -> a.aid)
890
+
|> Json.Codec.Object.mem "services" (Json.Codec.list service) ~enc:(fun a ->
896
891
a.services)
897
-
|> Json.Object.finish
892
+
|> Json.Codec.Object.finish
898
893
899
894
type accessories_response = { accessories : accessory list }
900
895
(** HAP accessories response *)
901
896
902
897
let accessories_response =
903
-
Json.Object.map ~kind:"hap.accessories_response" (fun accessories ->
898
+
Json.Codec.Object.map ~kind:"hap.accessories_response" (fun accessories ->
904
899
{ accessories })
905
-
|> Json.Object.mem "accessories" (Json.list accessory) ~enc:(fun r ->
906
-
r.accessories)
907
-
|> Json.Object.finish
900
+
|> Json.Codec.Object.mem "accessories" (Json.Codec.list accessory)
901
+
~enc:(fun r -> r.accessories)
902
+
|> Json.Codec.Object.finish
908
903
909
904
type char_value = { aid : int; iid : int; value : Json.t option }
910
905
(** HAP characteristics value *)
911
906
912
907
let char_value =
913
-
Json.Object.map ~kind:"hap.char_value" (fun aid iid value ->
908
+
Json.Codec.Object.map ~kind:"hap.char_value" (fun aid iid value ->
914
909
{ aid; iid; value })
915
-
|> Json.Object.mem "aid" Json.int ~enc:(fun c -> c.aid)
916
-
|> Json.Object.mem "iid" Json.int ~enc:(fun c -> c.iid)
917
-
|> Json.Object.opt_mem "value" Json.json ~enc:(fun c -> c.value)
918
-
|> Json.Object.finish
910
+
|> Json.Codec.Object.mem "aid" Json.Codec.int ~enc:(fun c -> c.aid)
911
+
|> Json.Codec.Object.mem "iid" Json.Codec.int ~enc:(fun c -> c.iid)
912
+
|> Json.Codec.Object.opt_mem "value" Json.Codec.Value.t ~enc:(fun c ->
913
+
c.value)
914
+
|> Json.Codec.Object.finish
919
915
920
916
type characteristics_response = { characteristics : char_value list }
921
917
922
918
let characteristics_response =
923
-
Json.Object.map ~kind:"hap.characteristics_response"
919
+
Json.Codec.Object.map ~kind:"hap.characteristics_response"
924
920
(fun characteristics -> { characteristics })
925
-
|> Json.Object.mem "characteristics" (Json.list char_value) ~enc:(fun r ->
926
-
r.characteristics)
927
-
|> Json.Object.finish
921
+
|> Json.Codec.Object.mem "characteristics" (Json.Codec.list char_value)
922
+
~enc:(fun r -> r.characteristics)
923
+
|> Json.Codec.Object.finish
928
924
end
929
925
930
926
(** {1 High-level control} *)
···
934
930
let on = "25" (* 00000025-0000-1000-8000-0026BB765291 *)
935
931
end
936
932
937
-
(* Decode Json.json via codec *)
933
+
(* Decode Json.t via codec *)
938
934
let decode codec json =
939
-
match Json_bytesrw.encode_string Json.json json with
935
+
match Json.Value.to_string json with
940
936
| Error e -> Error e
941
937
| Ok str -> (
942
-
match Json_bytesrw.decode_string codec str with
943
-
| Ok v -> Ok v
944
-
| Error e -> Error e)
938
+
match Json.of_string codec str with Ok v -> Ok v | Error e -> Error e)
945
939
946
940
(* Find the On characteristic IID from accessories JSON *)
947
941
let on_characteristic_iid json =
-1
ocaml-hcomp/fuzz/dune
-1
ocaml-hcomp/fuzz/dune
-1
ocaml-homebrew/fuzz/dune
-1
ocaml-homebrew/fuzz/dune
-1
ocaml-hostname/fuzz/dune
-1
ocaml-hostname/fuzz/dune
-1
ocaml-idc/fuzz/dune
-1
ocaml-idc/fuzz/dune
-1
ocaml-json-logs/fuzz/dune
-1
ocaml-json-logs/fuzz/dune
-1
ocaml-jwt/fuzz/dune
-1
ocaml-jwt/fuzz/dune
-12
ocaml-jwt/lib/cwt.ml
-12
ocaml-jwt/lib/cwt.ml
···
693
693
| Algorithm.HMAC_384 -> 48
694
694
| Algorithm.HMAC_512 -> 64
695
695
696
-
let ecdsa_verify_sig ~pub_of_octets ~hash_mod ~half_len ~curve_name ~x ~y
697
-
~signature ~msg =
698
-
match pub_of_octets ("\x04" ^ x ^ y) with
699
-
| Ok pub ->
700
-
let hash = hash_mod msg in
701
-
let r = String.sub signature 0 half_len in
702
-
let s = String.sub signature half_len half_len in
703
-
if Crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash then Ok ()
704
-
else Error Signature_mismatch
705
-
| Error _ ->
706
-
Error (Key_type_mismatch ("Invalid " ^ curve_name ^ " public key"))
707
-
708
696
let verify_signature alg key_data ~sig_structure ~signature =
709
697
match (alg, key_data) with
710
698
| ( ( Algorithm.HMAC_256_64 | Algorithm.HMAC_256 | Algorithm.HMAC_384
-1
ocaml-kepler/fuzz/dune
-1
ocaml-kepler/fuzz/dune
-2
ocaml-kepler/test/test_analytic.ml
-2
ocaml-kepler/test/test_analytic.ml
-3
ocaml-kepler/test/test_propagate.ml
-3
ocaml-kepler/test/test_propagate.ml
···
9
9
(** Position accuracy ~1 km after short propagation (RK4 vs analytical). *)
10
10
let eps_km = 1.0
11
11
12
-
(** Specific energy conservation tolerance. *)
13
-
let eps_energy = 1e-4
14
-
15
12
let check_float msg eps expected actual =
16
13
Alcotest.(check (float eps)) msg expected actual
17
14
-1
ocaml-ldpc/fuzz/dune
-1
ocaml-ldpc/fuzz/dune
-1
ocaml-leb128/fuzz/dune
-1
ocaml-leb128/fuzz/dune
-9
ocaml-lfsr/test/test_lfsr.ml
-9
ocaml-lfsr/test/test_lfsr.ml
···
3
3
SPDX-License-Identifier: MIT
4
4
---------------------------------------------------------------------------*)
5
5
6
-
let hex_of_bytes b =
7
-
let buf = Buffer.create (Bytes.length b * 3) in
8
-
Bytes.iteri
9
-
(fun i c ->
10
-
if i > 0 then Buffer.add_char buf ' ';
11
-
Buffer.add_string buf (Fmt.str "%02X" (Char.code c)))
12
-
b;
13
-
Buffer.contents buf
14
-
15
6
let bytes_of_hex s =
16
7
let s = String.concat "" (String.split_on_char ' ' s) in
17
8
let len = String.length s / 2 in
+7
-2
ocaml-loc/lib/loc.ml
+7
-2
ocaml-loc/lib/loc.ml
···
327
327
let push_mem sort n ctx = push ~sort (Path.Mem n) ctx
328
328
let push_array = push_nth
329
329
let push_object = push_mem
330
+
330
331
(* Context's raw storage is ROOT-to-LEAF: the push-on-way-up semantics
331
332
used by decoders (inner catcher fires first, outer last) means outer
332
333
frames are consed LAST, so they sit at the head. Path's raw storage
333
334
is LEAF-to-ROOT (cons at head during descent) -- the conventions
334
335
mirror each other. Accessors bridge the two. *)
335
-
let last_step ctx = match List.rev ctx with [] -> None | f :: _ -> Some f.step
336
-
let last_sort ctx = match List.rev ctx with [] -> None | f :: _ -> Some f.sort
336
+
let last_step ctx =
337
+
match List.rev ctx with [] -> None | f :: _ -> Some f.step
338
+
339
+
let last_sort ctx =
340
+
match List.rev ctx with [] -> None | f :: _ -> Some f.sort
341
+
337
342
let frames ctx = List.map (fun f -> (f.sort, f.step)) ctx
338
343
let rev_frames ctx = List.rev (frames ctx)
339
344
+4
-4
ocaml-loc/lib/loc.mli
+4
-4
ocaml-loc/lib/loc.mli
···
317
317
[None] at the root. *)
318
318
319
319
val frames : t -> (string node * Path.step) list
320
-
(** [frames ctx] is the list of [(sort, step)] frames in root-to-leaf
321
-
order. *)
320
+
(** [frames ctx] is the list of [(sort, step)] frames in root-to-leaf order.
321
+
*)
322
322
323
323
val rev_frames : t -> (string node * Path.step) list
324
324
(** [rev_frames ctx] is the list of [(sort, step)] frames in leaf-to-root
325
-
order (the raw internal order). Cheaper than {!frames}; use when
326
-
iteration order is irrelevant. *)
325
+
order (the raw internal order). Cheaper than {!frames}; use when iteration
326
+
order is irrelevant. *)
327
327
328
328
(** {2:compat Legacy push helpers} *)
329
329
+3
-8
ocaml-loc/test/test_loc.ml
+3
-8
ocaml-loc/test/test_loc.ml
···
203
203
let meta_of_sample = Loc.Meta.make sample
204
204
205
205
let error_msg () =
206
-
let e =
207
-
Loc.Error.msg ~ctx:Loc.Context.empty ~meta:meta_of_sample "boom"
208
-
in
206
+
let e = Loc.Error.msg ~ctx:Loc.Context.empty ~meta:meta_of_sample "boom" in
209
207
let s = Loc.Error.to_string e in
210
208
Alcotest.(check bool) "contains msg" true (contains_substring "boom" s);
211
209
Alcotest.(check bool) "contains file" true (contains_substring "foo.ml" s)
···
236
234
(contains_substring "found string" s)
237
235
238
236
let error_push_context () =
239
-
let e =
240
-
Loc.Error.msg ~ctx:Loc.Context.empty ~meta:meta_of_sample "bad"
241
-
in
237
+
let e = Loc.Error.msg ~ctx:Loc.Context.empty ~meta:meta_of_sample "bad" in
242
238
let kinded = ("array", Loc.Meta.none) in
243
239
let n = (3, Loc.Meta.none) in
244
240
try
···
246
242
Alcotest.fail "expected Error"
247
243
with Loc.Error e ->
248
244
let ctx = Loc.Error.ctx e in
249
-
Alcotest.(check bool)
250
-
"ctx non-empty" false (Loc.Context.is_empty ctx);
245
+
Alcotest.(check bool) "ctx non-empty" false (Loc.Context.is_empty ctx);
251
246
Alcotest.(check int)
252
247
"one layer" 1
253
248
(List.length (Loc.Path.rev_steps (Loc.Context.path ctx)))
-1
ocaml-ltp/c/dune
-1
ocaml-ltp/c/dune
-1
ocaml-ltp/fuzz/dune
-1
ocaml-ltp/fuzz/dune
-1
ocaml-matter/fuzz/dune
-1
ocaml-matter/fuzz/dune
+2
-18
ocaml-matter/lib/case.ml
+2
-18
ocaml-matter/lib/case.ml
···
31
31
32
32
type initiator_state = {
33
33
i_credentials : credentials;
34
-
i_peer_fabric : fabric;
35
-
i_session_id : int;
36
34
i_random : string;
37
35
i_eph_priv : Crypto_ec.P256.Dh.secret;
38
36
i_eph_pub : string;
39
37
}
40
38
41
39
type responder_state = {
42
-
r_credentials : credentials;
43
-
r_session_id : int;
44
40
r_random : string;
45
-
r_eph_priv : Crypto_ec.P256.Dh.secret;
46
41
r_eph_pub : string;
47
42
r_peer_eph_pub : string;
48
-
r_peer_session_id : int;
49
43
r_peer_random : string;
50
44
r_shared_secret : string;
51
45
}
···
384
378
let state =
385
379
{
386
380
i_credentials = credentials;
387
-
i_peer_fabric = peer_fabric;
388
-
i_session_id = initiator_session_id;
389
381
i_random = random;
390
382
i_eph_priv = eph_priv;
391
383
i_eph_pub = eph_pub;
···
504
496
let s2k = derive_sigma_key ~shared_secret ~salt ~info:sigma2_info in
505
497
aes_ccm_encrypt ~key:s2k ~nonce ~adata:"" tbs2_inner
506
498
507
-
let responder_build_state ~credentials ~(sigma1 : sigma1) ~responder_session_id
508
-
~random ~eph_priv ~eph_pub ~shared_secret =
499
+
let responder_build_state ~(sigma1 : sigma1) ~random ~eph_pub ~shared_secret =
509
500
{
510
-
r_credentials = credentials;
511
-
r_session_id = responder_session_id;
512
501
r_random = random;
513
-
r_eph_priv = eph_priv;
514
502
r_eph_pub = eph_pub;
515
503
r_peer_eph_pub = sigma1.initiator_eph_pub_key;
516
-
r_peer_session_id = sigma1.initiator_session_id;
517
504
r_peer_random = sigma1.initiator_random;
518
505
r_shared_secret = shared_secret;
519
506
}
···
536
523
responder_sign_and_encrypt ~credentials ~sigma1 ~random ~eph_pub
537
524
~shared_secret
538
525
in
539
-
let state =
540
-
responder_build_state ~credentials ~sigma1 ~responder_session_id ~random
541
-
~eph_priv ~eph_pub ~shared_secret
542
-
in
526
+
let state = responder_build_state ~sigma1 ~random ~eph_pub ~shared_secret in
543
527
let sigma2 =
544
528
{
545
529
responder_random = random;
-1
ocaml-mbr/c/dune
-1
ocaml-mbr/c/dune
-1
ocaml-mbr/fuzz/dune
-1
ocaml-mbr/fuzz/dune
+1
-2
ocaml-mbr/lib/dune
+1
-2
ocaml-mbr/lib/dune
-1
ocaml-mdns/fuzz/dune
-1
ocaml-mdns/fuzz/dune
-1
ocaml-merge3/test/dune
-1
ocaml-merge3/test/dune
+1
-2
ocaml-merlin/dune-project
+1
-2
ocaml-merlin/dune-project
+1
-2
ocaml-merlin/fuzz/dune
+1
-2
ocaml-merlin/fuzz/dune
+1
-1
ocaml-merlin/fuzz/fuzz_merlin.ml
+1
-1
ocaml-merlin/fuzz/fuzz_merlin.ml
···
122
122
123
123
(** Random JSON input - must not crash the parser. *)
124
124
let test_json_crash_safety input =
125
-
let _ = Jsont_bytesrw.decode_string Jsont.json input in
125
+
let _ = Json.Value.of_string input in
126
126
()
127
127
128
128
(** Scope conversion - all scopes must have string representation. *)
+1
-2
ocaml-merlin/lib/dune
+1
-2
ocaml-merlin/lib/dune
+2
-1
ocaml-merlin/lib/merlin.ml
+2
-1
ocaml-merlin/lib/merlin.ml
···
727
727
728
728
let err_exit_code n = Error (Fmt.str "Merlin exited with code %d" n)
729
729
let err_signal n = Error (Fmt.str "Merlin killed by signal %d" n)
730
+
730
731
let err_invalid kind e =
731
732
Error (Fmt.str "Invalid %s response: %a" kind Json.Error.pp e)
732
733
···
751
752
Log.debug (fun m -> m "Merlin returned empty output");
752
753
Ok (Json.Null ((), Json.Meta.none)))
753
754
else
754
-
match Json.of_string Json.Codec.Value.t output_str with
755
+
match Json.Value.of_string output_str with
755
756
| Ok json ->
756
757
Log.debug (fun m -> m "Merlin completed successfully");
757
758
Ok json
+1
-1
ocaml-merlin/ocaml-merlin.opam
+1
-1
ocaml-merlin/ocaml-merlin.opam
+4
-2
ocaml-meross/lib/protocol.ml
+4
-2
ocaml-meross/lib/protocol.ml
···
121
121
122
122
(** {1 JSON Helpers} *)
123
123
124
-
let decode codec s = Result.map_error Json.Error.to_string (Json.of_string codec s)
125
-
let encode codec v = Json.to_string codec v |> Result.value ~default:""
124
+
let decode codec s =
125
+
Result.map_error Json.Error.to_string (Json.of_string codec s)
126
+
127
+
let encode codec v = Json.to_string codec v
126
128
127
129
(** {1 Request Builders} *)
128
130
-1
ocaml-mst/fuzz/dune
-1
ocaml-mst/fuzz/dune
+1
-1
ocaml-oci/test/spec/dune
+1
-1
ocaml-oci/test/spec/dune
+2
-2
ocaml-oci/test/spec/test_common.ml
+2
-2
ocaml-oci/test/spec/test_common.ml
···
3
3
let test_json_roundtrip () =
4
4
let json_str = {|{"foo":"bar","n":42}|} in
5
5
match Common.json_of_string json_str with
6
-
| Error e -> Alcotest.failf "json_of_string: %s" (Json.Error.to_string e)
6
+
| Error e -> Alcotest.failf "json_of_string: %s" (Loc.Error.to_string e)
7
7
| Ok json ->
8
8
let s = Common.json_to_string json in
9
9
Alcotest.(check bool) "non-empty" true (String.length s > 0)
···
41
41
let encoded = Common.Base64.encode original in
42
42
match Common.Base64.decode encoded with
43
43
| Ok decoded -> Alcotest.(check string) "roundtrip" original decoded
44
-
| Error (`Msg e) -> Alcotest.failf "decode: %s" e
44
+
| Error (`Msg e) -> Alcotest.failf "decode: %s" (Loc.Error.to_string e)
45
45
46
46
let suite =
47
47
( "common",
+2
-2
ocaml-odm/test/test_oem.ml
+2
-2
ocaml-odm/test/test_oem.ml
···
68
68
ignore (Fmt.str "%a" Odm.pp oem)
69
69
70
70
(* Parse an invalid OEM file — should either return Error or at least not crash *)
71
-
let check_invalid name path () =
71
+
let check_invalid path () =
72
72
if skip_if_no_vectors () then ()
73
73
else
74
74
let content = read_file path in
···
128
128
let name = Filename.chop_extension f in
129
129
Alcotest.test_case
130
130
(Fmt.str "invalid %s" name)
131
-
`Quick (check_invalid name path))
131
+
`Quick (check_invalid path))
132
132
133
133
(* Specific checks on real orbit data *)
134
134
let leo_orbit_checks () =
-1
ocaml-oem/fuzz/dune
-1
ocaml-oem/fuzz/dune
-1
ocaml-opam/lib/dune
-1
ocaml-opam/lib/dune
-10
ocaml-opam/test/dune
-10
ocaml-opam/test/dune
-1
ocaml-openamp/fuzz/dune
-1
ocaml-openamp/fuzz/dune
+1
-1
ocaml-osv/lib/dune
+1
-1
ocaml-osv/lib/dune
+2
-1
ocaml-osv/lib/osv.ml
+2
-1
ocaml-osv/lib/osv.ml
···
299
299
| Ok json -> (
300
300
match Json.of_string raw_batch_response_jsont json with
301
301
| Error msg ->
302
-
Log.err (fun f -> f "batch parse failed: %s" (Json.Error.to_string msg));
302
+
Log.err (fun f ->
303
+
f "batch parse failed: %s" (Json.Error.to_string msg));
303
304
List.map (fun purl -> (purl, [])) purls
304
305
| Ok resp ->
305
306
let parsed =
-1
ocaml-osv/test/dune
-1
ocaml-osv/test/dune
-1
ocaml-pbkdf2/fuzz/dune
-1
ocaml-pbkdf2/fuzz/dune
+3
-6
ocaml-pds/lib/pds.ml
+3
-6
ocaml-pds/lib/pds.ml
···
4
4
---------------------------------------------------------------------------*)
5
5
6
6
type t = {
7
-
path : Eio.Fs.dir_ty Eio.Path.t;
8
7
db : Sqlite.t;
9
-
blocks : Sqlite.Table.t;
10
8
refs : Sqlite.Table.t;
11
-
meta : Sqlite.Table.t;
12
9
blobs : Blob_store.t;
13
10
blockstore : Atp.Blockstore.writable;
14
-
mutable did : Atp.Did.t;
11
+
did : Atp.Did.t;
15
12
}
16
13
17
14
(* Repository layout:
···
35
32
(* Store DID in metadata *)
36
33
Sqlite.Table.put meta "did" (Atp.Did.to_string did);
37
34
Sqlite.Table.put meta "version" "1";
38
-
let t = { path; db; blocks; refs; meta; blobs; blockstore; did } in
35
+
let t = { db; refs; blobs; blockstore; did } in
39
36
Eio.Switch.on_release sw (fun () -> Sqlite.close db);
40
37
t
41
38
···
59
56
| Some s -> Atp.Did.of_string_exn s
60
57
| None -> failwith "PDS metadata missing DID"
61
58
in
62
-
let t = { path; db; blocks; refs; meta; blobs; blockstore; did } in
59
+
let t = { db; refs; blobs; blockstore; did } in
63
60
Eio.Switch.on_release sw (fun () -> Sqlite.close db);
64
61
t
65
62
-1
ocaml-pid1/c/dune
-1
ocaml-pid1/c/dune
-1
ocaml-pid1/test/dune
-1
ocaml-pid1/test/dune
+1
-1
ocaml-protobuf/fuzz/fuzz_protobuf.ml
+1
-1
ocaml-protobuf/fuzz/fuzz_protobuf.ml
···
189
189
let s = Protobuf.encode_string kitchen_codec k in
190
190
match Protobuf.decode_string kitchen_codec s with
191
191
| Error msg ->
192
-
Alcobar.pp Format.err_formatter "%s\n" msg;
192
+
Alcobar.pp Format.err_formatter "%s\n" (Protobuf.Error.to_string msg);
193
193
guard false
194
194
| Ok k' -> check_eq ~eq:kitchen_equal ~pp:pp_kitchen k k'
195
195
+1
-1
ocaml-protobuf/lib/dune
+1
-1
ocaml-protobuf/lib/dune
+19
-9
ocaml-protobuf/lib/protobuf.ml
+19
-9
ocaml-protobuf/lib/protobuf.ml
···
7
7
combinator call sites. *)
8
8
9
9
module Wire = Wire
10
+
module Error = Error
10
11
11
12
(* -- Nested-message depth tracking.
12
13
···
789
790
| other -> write_value buf other v));
790
791
Buffer.contents buf
791
792
792
-
let decode_string : type a. a t -> string -> (a, string) result =
793
+
let decode_string : type a. a t -> string -> (a, Error.t) result =
793
794
fun codec s ->
794
795
depth := 0;
795
796
try
···
800
801
let v, off = decode_bytes codec s 0 in
801
802
if off <> String.length s then
802
803
Error
803
-
(Fmt.str "trailing %d bytes after scalar" (String.length s - off))
804
+
(Error.of_wire_error
805
+
(Fmt.str "trailing %d bytes after scalar"
806
+
(String.length s - off)))
804
807
else Ok v
805
808
| Rec c -> (
806
809
match Lazy.force c with
···
810
813
let v, off = decode_bytes other s 0 in
811
814
if off <> String.length s then
812
815
Error
813
-
(Fmt.str "trailing %d bytes after scalar"
814
-
(String.length s - off))
816
+
(Error.of_wire_error
817
+
(Fmt.str "trailing %d bytes after scalar"
818
+
(String.length s - off)))
815
819
else Ok v)
816
-
with Wire.Decode_error msg -> Error msg
820
+
with Wire.Decode_error msg -> Error (Error.of_wire_error msg)
817
821
818
822
let encode codec w v =
819
823
let s = encode_string codec v in
···
842
846
[Error]. *)
843
847
844
848
let decode_with_unknowns_string : type a.
845
-
a t -> string -> (a * string, string) result =
849
+
a t -> string -> (a * string, Error.t) result =
846
850
fun codec s ->
847
851
depth := 0;
848
852
try
···
851
855
| Rec c -> (
852
856
match Lazy.force c with
853
857
| Message m -> Ok (m.decode_body_with_unknowns s 0 (String.length s))
854
-
| _ -> Error "decode_with_unknowns_string: codec is not a message")
855
-
| _ -> Error "decode_with_unknowns_string: codec is not a message"
856
-
with Wire.Decode_error msg -> Error msg
858
+
| _ ->
859
+
Error
860
+
(Error.of_wire_error
861
+
"decode_with_unknowns_string: codec is not a message"))
862
+
| _ ->
863
+
Error
864
+
(Error.of_wire_error
865
+
"decode_with_unknowns_string: codec is not a message")
866
+
with Wire.Decode_error msg -> Error (Error.of_wire_error msg)
857
867
858
868
let encode_with_unknowns_string : type a. a t -> unknowns:string -> a -> string
859
869
=
+9
-4
ocaml-protobuf/lib/protobuf.mli
+9
-4
ocaml-protobuf/lib/protobuf.mli
···
185
185
(** [encode_string c v] encodes [v] as a protobuf message body (no outer length
186
186
prefix). *)
187
187
188
-
val decode_string : 'a t -> string -> ('a, string) result
188
+
module Error = Error
189
+
(** Structured decode errors extending {!Loc.Error}. *)
190
+
191
+
val decode_string : 'a t -> string -> ('a, Error.t) result
189
192
(** [decode_string c s] decodes the entire input as a message body. Returns
190
-
[Error msg] on malformed input; trailing garbage is an error. *)
193
+
[Error e] on malformed input; trailing garbage is an error. Use
194
+
{!Error.to_string} to render a human-readable message. *)
191
195
192
196
val encode : 'a t -> Bytesrw.Bytes.Writer.t -> 'a -> unit
193
197
(** [encode c w v] encodes [v] and writes it to [w] as a single slice. Useful
194
198
for composition with other bytesrw pipelines. *)
195
199
196
-
val decode : 'a t -> Bytesrw.Bytes.Reader.t -> ('a, string) result
200
+
val decode : 'a t -> Bytesrw.Bytes.Reader.t -> ('a, Error.t) result
197
201
(** [decode c r] drains [r] to end-of-data and decodes the full content. *)
198
202
199
203
(** {1 Unknown field preservation}
···
202
206
preserve them so a decoded-then-re-encoded message round-trips even when
203
207
intermediate tooling runs an older schema. *)
204
208
205
-
val decode_with_unknowns_string : 'a t -> string -> ('a * string, string) result
209
+
val decode_with_unknowns_string :
210
+
'a t -> string -> ('a * string, Error.t) result
206
211
(** [decode_with_unknowns_string c s] returns [Ok (value, unknown_wire)] where
207
212
[unknown_wire] is a byte string holding the wire bytes of every tag that was
208
213
not in the schema, re-serialized in canonical form and sorted by tag. Pair
+4
-2
ocaml-protobuf/test/interop/protoc/test.ml
+4
-2
ocaml-protobuf/test/interop/protoc/test.ml
···
57
57
r.wire_hex (hex_encode our_wire);
58
58
(* decode direction: our codec reads protoc's bytes into the same value *)
59
59
match Protobuf.decode_string test1_codec expected_wire with
60
-
| Error msg -> Alcotest.failf "%s: decode failed: %s" r.name msg
60
+
| Error msg ->
61
+
Alcotest.failf "%s: decode failed: %a" r.name Protobuf.Error.pp msg
61
62
| Ok decoded ->
62
63
Alcotest.(check int32) (Fmt.str "decode %s" r.name) r.a decoded.a)
63
64
rows
···
164
165
(fun (r : everything_row) ->
165
166
let expected_wire = hex_decode r.wire_hex in
166
167
match Protobuf.decode_string everything_codec expected_wire with
167
-
| Error msg -> Alcotest.failf "%s: decode failed: %s" r.name msg
168
+
| Error msg ->
169
+
Alcotest.failf "%s: decode failed: %a" r.name Protobuf.Error.pp msg
168
170
| Ok decoded ->
169
171
let reencoded = Protobuf.encode_string everything_codec decoded in
170
172
Alcotest.(check string)
+38
-28
ocaml-protobuf/test/test_protobuf.ml
+38
-28
ocaml-protobuf/test/test_protobuf.ml
···
22
22
let wire = Protobuf.encode_string test1_codec { a = 150l } in
23
23
Alcotest.(check string) "Test1 a=150" "089601" (hex wire);
24
24
match Protobuf.decode_string test1_codec wire with
25
-
| Error msg -> Alcotest.fail msg
25
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
26
26
| Ok r -> Alcotest.(check int32) "decoded a" 150l r.a
27
27
28
28
(* --- Test 2: message Test2 { string b = 2; } with b = "testing". --- *)
···
39
39
let wire = Protobuf.encode_string test2_codec { b = "testing" } in
40
40
Alcotest.(check string) "Test2 b=testing" "120774657374696e67" (hex wire);
41
41
match Protobuf.decode_string test2_codec wire with
42
-
| Error msg -> Alcotest.fail msg
42
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
43
43
| Ok r -> Alcotest.(check string) "decoded b" "testing" r.b
44
44
45
45
(* --- Test 3: a record with every scalar type. --- *)
···
121
121
in
122
122
let wire = Protobuf.encode_string all_scalars_codec v in
123
123
match Protobuf.decode_string all_scalars_codec wire with
124
-
| Error msg -> Alcotest.fail msg
124
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
125
125
| Ok r ->
126
126
Alcotest.(check int32) "i32" v.i32 r.i32;
127
127
Alcotest.(check int64) "i64" v.i64 r.i64;
···
154
154
let v = { name = Some "Ada"; age = Some 36l } in
155
155
let wire = Protobuf.encode_string opt_codec v in
156
156
match Protobuf.decode_string opt_codec wire with
157
-
| Error msg -> Alcotest.fail msg
157
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
158
158
| Ok r ->
159
159
Alcotest.(check (option string)) "name" v.name r.name;
160
160
Alcotest.(check (option int32)) "age" v.age r.age
···
164
164
let wire = Protobuf.encode_string opt_codec v in
165
165
Alcotest.(check int) "empty wire" 0 (String.length wire);
166
166
match Protobuf.decode_string opt_codec wire with
167
-
| Error msg -> Alcotest.fail msg
167
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
168
168
| Ok r ->
169
169
Alcotest.(check (option string)) "name" None r.name;
170
170
Alcotest.(check (option int32)) "age" None r.age
···
173
173
let v = { name = Some "solo"; age = None } in
174
174
let wire = Protobuf.encode_string opt_codec v in
175
175
match Protobuf.decode_string opt_codec wire with
176
-
| Error msg -> Alcotest.fail msg
176
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
177
177
| Ok r ->
178
178
Alcotest.(check (option string)) "name" (Some "solo") r.name;
179
179
Alcotest.(check (option int32)) "age" None r.age
···
192
192
let v = { tags = [ "a"; "bb"; "ccc" ] } in
193
193
let wire = Protobuf.encode_string rep_str_codec v in
194
194
match Protobuf.decode_string rep_str_codec wire with
195
-
| Error msg -> Alcotest.fail msg
195
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
196
196
| Ok r -> Alcotest.(check (list string)) "tags" v.tags r.tags
197
197
198
198
(* --- Test 6: packed repeated varint. --- *)
···
211
211
(* Tag 1 wire type 2 (length-delim), length 5, body = 01 02 03 96 01 *)
212
212
Alcotest.(check string) "packed wire" "0a050102039601" (hex wire);
213
213
match Protobuf.decode_string packed_codec wire with
214
-
| Error msg -> Alcotest.fail msg
214
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
215
215
| Ok r -> Alcotest.(check (list int32)) "nums" v.nums r.nums
216
216
217
217
let test_packed_accepts_non_packed () =
···
227
227
Protobuf.encode_string unpacked_codec { nums = [ 1l; 2l; 3l; 150l ] }
228
228
in
229
229
match Protobuf.decode_string packed_codec unpacked_wire with
230
-
| Error msg -> Alcotest.fail msg
230
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
231
231
| Ok r -> Alcotest.(check (list int32)) "nums" [ 1l; 2l; 3l; 150l ] r.nums
232
232
233
233
(* --- Test 7: nested messages. --- *)
···
253
253
let v = { inner = { x = 42l }; label = "hi" } in
254
254
let wire = Protobuf.encode_string outer_codec v in
255
255
match Protobuf.decode_string outer_codec wire with
256
-
| Error msg -> Alcotest.fail msg
256
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
257
257
| Ok r ->
258
258
Alcotest.(check int32) "inner.x" 42l r.inner.x;
259
259
Alcotest.(check string) "label" "hi" r.label
···
270
270
Protobuf.Wire.write_string buf "extra-junk";
271
271
let wire = Buffer.contents buf in
272
272
match Protobuf.decode_string test1_codec wire with
273
-
| Error msg -> Alcotest.fail msg
273
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
274
274
| Ok r -> Alcotest.(check int32) "a decoded despite stray tag 99" 150l r.a
275
275
276
276
(* --- Test 9: field out-of-order on the wire. --- *)
···
285
285
Protobuf.Wire.write_int32 buf 7l;
286
286
let wire = Buffer.contents buf in
287
287
match Protobuf.decode_string all_scalars_codec wire with
288
-
| Error msg -> Alcotest.fail msg
288
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
289
289
| Ok r ->
290
290
Alcotest.(check int32) "i32 decoded" 7l r.i32;
291
291
Alcotest.(check string) "str decoded" "backwards" r.str;
···
316
316
let v = { entries = [ ("alice", 30l); ("bob", 25l); ("", 0l) ] } in
317
317
let wire = Protobuf.encode_string dict_codec v in
318
318
match Protobuf.decode_string dict_codec wire with
319
-
| Error msg -> Alcotest.fail msg
319
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
320
320
| Ok r ->
321
321
Alcotest.(check int) "entry count" 3 (List.length r.entries);
322
322
Alcotest.(check (list (pair string int32))) "entries" v.entries r.entries
···
349
349
{ a = 42l; b = "hello"; c = [ 1l; 2l; 3l ] }
350
350
in
351
351
match Protobuf.decode_with_unknowns_string schema_v1 original with
352
-
| Error msg -> Alcotest.fail msg
352
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
353
353
| Ok (v1, unknowns) -> (
354
354
Alcotest.(check int32) "a decoded" 42l v1.a;
355
355
Alcotest.(check bool)
···
361
361
Protobuf.encode_with_unknowns_string schema_v1 ~unknowns { a = v1.a }
362
362
in
363
363
match Protobuf.decode_string schema_v2 reemitted with
364
-
| Error msg -> Alcotest.failf "v2 re-decode failed: %s" msg
364
+
| Error msg ->
365
+
Alcotest.failf "v2 re-decode failed: %s"
366
+
(Protobuf.Error.to_string msg)
365
367
| Ok v2' ->
366
368
Alcotest.(check int32) "a survived" 42l v2'.a;
367
369
Alcotest.(check string) "b survived" "hello" v2'.b;
···
370
372
let test_unknowns_empty_when_schema_matches () =
371
373
let wire = Protobuf.encode_string schema_v1 { a = 42l } in
372
374
match Protobuf.decode_with_unknowns_string schema_v1 wire with
373
-
| Error msg -> Alcotest.fail msg
375
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
374
376
| Ok (_, unknowns) ->
375
377
Alcotest.(check int) "no unknowns" 0 (String.length unknowns)
376
378
377
379
(* --- Test 13: oneof --- *)
378
380
379
381
type payload = [ `None | `Text of string | `Num of int32 | `Blob of string ]
380
-
381
382
type msg_with_payload = { payload : payload }
382
383
383
384
let msg_with_payload_codec : msg_with_payload Protobuf.t =
···
404
405
let v = { payload = `Text "hello" } in
405
406
let wire = Protobuf.encode_string msg_with_payload_codec v in
406
407
match Protobuf.decode_string msg_with_payload_codec wire with
407
-
| Error msg -> Alcotest.fail msg
408
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
408
409
| Ok r -> Alcotest.(check bool) "roundtrip" true (r.payload = `Text "hello")
409
410
410
411
let test_oneof_num () =
411
412
let v = { payload = `Num 42l } in
412
413
let wire = Protobuf.encode_string msg_with_payload_codec v in
413
414
match Protobuf.decode_string msg_with_payload_codec wire with
414
-
| Error msg -> Alcotest.fail msg
415
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
415
416
| Ok r -> Alcotest.(check bool) "roundtrip" true (r.payload = `Num 42l)
416
417
417
418
let test_oneof_none () =
···
419
420
let wire = Protobuf.encode_string msg_with_payload_codec v in
420
421
Alcotest.(check int) "empty wire" 0 (String.length wire);
421
422
match Protobuf.decode_string msg_with_payload_codec wire with
422
-
| Error msg -> Alcotest.fail msg
423
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
423
424
| Ok r -> Alcotest.(check bool) "payload is None" true (r.payload = `None)
424
425
425
426
let test_oneof_last_wins () =
···
435
436
Protobuf.Wire.write_string buf "winner";
436
437
let wire = Buffer.contents buf in
437
438
match Protobuf.decode_string msg_with_payload_codec wire with
438
-
| Error msg -> Alcotest.fail msg
439
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
439
440
| Ok r -> Alcotest.(check bool) "last wins" true (r.payload = `Blob "winner")
440
441
441
442
let test_map_empty () =
···
443
444
let wire = Protobuf.encode_string dict_codec v in
444
445
Alcotest.(check int) "empty wire" 0 (String.length wire);
445
446
match Protobuf.decode_string dict_codec wire with
446
-
| Error msg -> Alcotest.fail msg
447
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
447
448
| Ok r -> Alcotest.(check (list (pair string int32))) "entries" [] r.entries
448
449
449
450
(* A schema that declares no fields: every input is unknown. *)
···
501
502
let wire = Buffer.contents buf in
502
503
match Protobuf.decode_string empty_codec wire with
503
504
| Ok () -> ()
504
-
| Error msg -> Alcotest.failf "10k unknown fields rejected: %s" msg
505
+
| Error msg ->
506
+
Alcotest.failf "10k unknown fields rejected: %s"
507
+
(Protobuf.Error.to_string msg)
505
508
506
509
(* =================================================================
507
510
CVE-2022-1941 (protobuf-c++, 2022): null-pointer dereference when
···
516
519
let wire = Protobuf.encode_string test1_codec { a = 42l } in
517
520
match Protobuf.decode_string empty_codec wire with
518
521
| Ok () -> ()
519
-
| Error msg -> Alcotest.failf "empty schema, all unknowns: %s" msg
522
+
| Error msg ->
523
+
Alcotest.failf "empty schema, all unknowns: %s"
524
+
(Protobuf.Error.to_string msg)
520
525
521
526
(* =================================================================
522
527
CVE-2022-3171 (protobuf-java, 2022): repeated group wire type
···
648
653
649
654
let test_empty_input () =
650
655
match Protobuf.decode_string test1_codec "" with
651
-
| Error msg -> Alcotest.failf "empty input should use defaults: %s" msg
656
+
| Error msg ->
657
+
Alcotest.failf "empty input should use defaults: %s"
658
+
(Protobuf.Error.to_string msg)
652
659
| Ok r -> Alcotest.(check int32) "a defaults to 0" 0l r.a
653
660
654
661
(* =================================================================
···
685
692
(* Not valid UTF-8 *)
686
693
let wire = Protobuf.encode_string with_str_codec { s = raw } in
687
694
match Protobuf.decode_string with_str_codec wire with
688
-
| Error msg -> Alcotest.failf "non-UTF-8 string must decode: %s" msg
695
+
| Error msg ->
696
+
Alcotest.failf "non-UTF-8 string must decode: %s"
697
+
(Protobuf.Error.to_string msg)
689
698
| Ok r -> Alcotest.(check string) "roundtrip" raw r.s
690
699
691
700
(* =================================================================
···
701
710
let v = { entries = [ ("k", 1l); ("k", 2l); ("x", 99l); ("k", 3l) ] } in
702
711
let wire = Protobuf.encode_string dict_codec v in
703
712
match Protobuf.decode_string dict_codec wire with
704
-
| Error msg -> Alcotest.fail msg
713
+
| Error e -> Alcotest.fail (Protobuf.Error.to_string e)
705
714
| Ok r ->
706
715
Alcotest.(check int) "entry count preserved" 4 (List.length r.entries)
707
716
···
728
737
done;
729
738
let wire = Buffer.contents buf in
730
739
match Protobuf.decode_string rep_codec wire with
731
-
| Error msg -> Alcotest.failf "many-repeated rejected: %s" msg
740
+
| Error msg ->
741
+
Alcotest.failf "many-repeated rejected: %s" (Protobuf.Error.to_string msg)
732
742
| Ok r ->
733
743
Alcotest.(check int) "count" n (List.length r.tags);
734
744
Alcotest.(check string) "first" "x" (List.hd r.tags)
-1
ocaml-proximity1/c/dune
-1
ocaml-proximity1/c/dune
-1
ocaml-proximity1/fuzz/dune
-1
ocaml-proximity1/fuzz/dune
-1
ocaml-publicsuffix/gen/dune
-1
ocaml-publicsuffix/gen/dune
-1
ocaml-publicsuffix/test/dune
-1
ocaml-publicsuffix/test/dune
-1
ocaml-punycode/fuzz/dune
-1
ocaml-punycode/fuzz/dune
+1
-2
ocaml-punycode/test/dune
+1
-2
ocaml-punycode/test/dune
-1
ocaml-pus/c/dune
-1
ocaml-pus/c/dune
-1
ocaml-pus/fuzz/dune
-1
ocaml-pus/fuzz/dune
+1
-1
ocaml-qemu/test/dune
+1
-1
ocaml-qemu/test/dune
-1
ocaml-rate-limit/fuzz/dune
-1
ocaml-rate-limit/fuzz/dune
-1
ocaml-reed-solomon/fuzz/dune
-1
ocaml-reed-solomon/fuzz/dune
+1
-1
ocaml-reed-solomon/lib/gf256.mli
+1
-1
ocaml-reed-solomon/lib/gf256.mli
-1
ocaml-reed-solomon/test/dune
-1
ocaml-reed-solomon/test/dune
+1
-1
ocaml-rego/lib/dune
+1
-1
ocaml-rego/lib/dune
+1
-2
ocaml-requests/dune-project
+1
-2
ocaml-requests/dune-project
+7
ocaml-requests/examples/dune
+7
ocaml-requests/examples/dune
···
25
25
(libraries requests eio eio_main crypto-rng.unix vlog)
26
26
(enabled_if
27
27
(= %{context_name} "default")))
28
+
29
+
(executable
30
+
(name session_example)
31
+
(modules session_example)
32
+
(libraries requests eio eio_main crypto-rng.unix vlog)
33
+
(enabled_if
34
+
(= %{context_name} "default")))
+9
-6
ocaml-requests/examples/session_example.ml
+9
-6
ocaml-requests/examples/session_example.ml
···
24
24
(* Example 2: POST with JSON body *)
25
25
Fmt.pr "\n=== Example 2: POST with JSON ===\n%!";
26
26
let json_data =
27
-
Jsont.Object
27
+
Json.Object
28
28
( [
29
-
("name", Jsont.String "Alice");
30
-
("email", Jsont.String "alice@example.com");
31
-
("age", Jsont.Number 30.0);
29
+
(("name", Json.Meta.none), Json.String ("Alice", Json.Meta.none));
30
+
( ("email", Json.Meta.none),
31
+
Json.String ("alice@example.com", Json.Meta.none) );
32
+
(("age", Json.Meta.none), Json.Number (30.0, Json.Meta.none));
32
33
],
33
-
Jsont.Meta.none )
34
+
Json.Meta.none )
34
35
in
35
36
let resp2 =
36
37
Requests.post req
···
43
44
Fmt.pr "\n=== Example 3: Custom Headers and Auth ===\n%!";
44
45
let headers =
45
46
Requests.Headers.empty
46
-
|> Requests.Headers.set "X-Custom-Header" "MyValue"
47
+
|> Requests.Headers.set
48
+
(Requests.Header_name.of_string "X-Custom-Header")
49
+
"MyValue"
47
50
|> Requests.Headers.user_agent "OCaml-Requests-Example/1.0"
48
51
in
49
52
let resp3 =
-1
ocaml-requests/fuzz/dune
-1
ocaml-requests/fuzz/dune
+1
-2
ocaml-requests/lib/oauth/oauth.ml
+1
-2
ocaml-requests/lib/oauth/oauth.ml
···
221
221
Log.info (fun m -> m "Received access token (type=%s)" token.token_type);
222
222
Ok token
223
223
with Json.Error e ->
224
-
Log.err (fun m ->
225
-
m "Failed to parse token response: %a" Json.Error.pp e);
224
+
Log.err (fun m -> m "Failed to parse token response: %a" Json.Error.pp e);
226
225
Error
227
226
{
228
227
code = Invalid_request;
+1
-1
ocaml-requests/requests.opam
+1
-1
ocaml-requests/requests.opam
+1
-3
ocaml-requests/test/features/test_signature.ml
+1
-3
ocaml-requests/test/features/test_signature.ml
···
841
841
in
842
842
match Signature.Content_digest.verify ~header:digest ~body with
843
843
| Ok () -> ()
844
-
| Error e ->
845
-
Alcotest.fail
846
-
("RFC Content-Digest verification failed: " ^ e)
844
+
| Error e -> Alcotest.fail ("RFC Content-Digest verification failed: " ^ e)
847
845
848
846
let rfc_hmac_tests =
849
847
[
+11
-8
ocaml-respond/lib/respond.ml
+11
-8
ocaml-respond/lib/respond.ml
···
308
308
in
309
309
loop pattern segs []
310
310
311
-
let match_route routes path =
311
+
let match_route ~meth routes path =
312
312
let rec loop = function
313
313
| [] -> None
314
-
| r :: rest -> (
314
+
| r :: rest when r.meth = meth -> (
315
315
match match_pattern r.pattern path with
316
316
| Some bindings -> Some (r, bindings)
317
317
| None -> loop rest)
318
+
| _ :: rest -> loop rest
318
319
in
319
320
loop routes
320
321
···
342
343
| "POST", url :: _ -> (
343
344
let path, params = parse_url url in
344
345
let body = read_body ~max_body_size reader headers in
345
-
match match_route routes path with
346
-
| Some ({ handler = Post handler; _ }, path_params) -> (
346
+
match match_route ~meth:`POST routes path with
347
+
| Some ({ raw; handler = Post handler; _ }, path_params) -> (
347
348
let req = { path; path_params; params; body; headers } in
348
349
try
349
350
let r = handler req in
350
351
Log.info (fun m ->
351
-
m "POST %s %s" path (status_line r.Response.status));
352
+
m "POST %s -> %s %s" path raw
353
+
(status_line r.Response.status));
352
354
send_response flow r
353
355
with exn ->
354
356
Log.err (fun m ->
···
361
363
| ("GET" | "HEAD"), url :: _ -> (
362
364
let is_head = meth_str = "HEAD" in
363
365
let path, params = parse_url url in
364
-
match match_route routes path with
365
-
| Some ({ handler = Get handler; _ }, path_params) -> (
366
+
match match_route ~meth:`GET routes path with
367
+
| Some ({ raw; handler = Get handler; _ }, path_params) -> (
366
368
try
367
369
let r = handler { path; path_params; params; headers } in
368
370
Log.info (fun m ->
369
-
m "%s %s %s" meth_str path (status_line r.Response.status));
371
+
m "%s %s -> %s %s" meth_str path raw
372
+
(status_line r.Response.status));
370
373
send_response ~head:is_head flow r
371
374
with exn ->
372
375
Log.err (fun m ->
+5
-4
ocaml-respond/lib/respond.mli
+5
-4
ocaml-respond/lib/respond.mli
···
127
127
(** [generate_etag ~size] produces a weak ETag string derived from the content
128
128
size. *)
129
129
130
-
val match_route : route list -> string -> (route * params) option
131
-
(** [match_route routes path] returns the first route whose pattern matches
132
-
[path], together with the captured [path_params]. Returns [None] if no route
133
-
matches. *)
130
+
val match_route :
131
+
meth:[ `GET | `POST ] -> route list -> string -> (route * params) option
132
+
(** [match_route ~meth routes path] returns the first route with HTTP method
133
+
[meth] whose pattern matches [path], together with the captured
134
+
[path_params]. Returns [None] if no route matches. *)
134
135
135
136
(** {1 Running} *)
136
137
-1
ocaml-retry/test/dune
-1
ocaml-retry/test/dune
-1
ocaml-rice/fuzz/dune
-1
ocaml-rice/fuzz/dune
-1
ocaml-rice/test/dune
-1
ocaml-rice/test/dune
-1
ocaml-rpmsg/c/dune
-1
ocaml-rpmsg/c/dune
-1
ocaml-rpmsg/fuzz/dune
-1
ocaml-rpmsg/fuzz/dune
-1
ocaml-rtlsdr/fuzz/dune
-1
ocaml-rtlsdr/fuzz/dune
-6
ocaml-rtlsdr/test/test_rtlsdr.ml
-6
ocaml-rtlsdr/test/test_rtlsdr.ml
···
1
1
let pi = Float.pi
2
2
3
-
let complex_testable =
4
-
Alcotest.testable
5
-
(fun ppf (c : Dsp.Complex.t) -> Fmt.pf ppf "(%f + %fi)" c.re c.im)
6
-
(fun (a : Dsp.Complex.t) (b : Dsp.Complex.t) ->
7
-
Float.abs (a.re -. b.re) < 1e-6 && Float.abs (a.im -. b.im) < 1e-6)
8
-
9
3
let approx_complex_testable eps =
10
4
Alcotest.testable
11
5
(fun ppf (c : Dsp.Complex.t) -> Fmt.pf ppf "(%f + %fi)" c.re c.im)
-1
ocaml-s3/fuzz/dune
-1
ocaml-s3/fuzz/dune
+1
-2
ocaml-sbom/lib/cyclonedx/cyclonedx.ml
+1
-2
ocaml-sbom/lib/cyclonedx/cyclonedx.ml
···
280
280
let bom ?serial_number ?metadata ?(version = 1) components =
281
281
{ spec_version = "1.6"; serial_number; version; metadata; components }
282
282
283
-
let to_string bom =
284
-
Json.to_string ~format:Json.Indent bom_jsont bom
283
+
let to_string bom = Json.to_string ~format:Json.Indent bom_jsont bom
285
284
286
285
type error = Malformed of { reason : string; loc : string option }
287
286
+1
-2
ocaml-sbom/lib/spdx/spdx.ml
+1
-2
ocaml-sbom/lib/spdx/spdx.ml
···
306
306
relationships;
307
307
}
308
308
309
-
let to_string doc =
310
-
Json.to_string ~format:Json.Indent document_jsont doc
309
+
let to_string doc = Json.to_string ~format:Json.Indent document_jsont doc
311
310
312
311
type error = Malformed of { reason : string; loc : string option }
313
312
+1
-1
ocaml-sbom/test/dune
+1
-1
ocaml-sbom/test/dune
+1
-1
ocaml-sbom/test/test_cyclonedx.ml
+1
-1
ocaml-sbom/test/test_cyclonedx.ml
···
1
1
let decode_ok codec s =
2
2
match Json.of_string codec s with
3
3
| Ok v -> v
4
-
| Error e -> Alcotest.failf "decode error: %s" (Json.Error.to_string e)
4
+
| Error e -> Alcotest.failf "decode error: %s" (Loc.Error.to_string e)
5
5
6
6
let roundtrip bom =
7
7
let json = Cyclonedx.to_string bom in
+1
-1
ocaml-sbom/test/test_sbom.ml
+1
-1
ocaml-sbom/test/test_sbom.ml
···
47
47
let decode_ok codec s =
48
48
match Json.of_string codec s with
49
49
| Ok v -> v
50
-
| Error e -> Alcotest.failf "decode error: %s" (Json.Error.to_string e)
50
+
| Error e -> Alcotest.failf "decode error: %s" (Loc.Error.to_string e)
51
51
52
52
let encode_ok codec v = Json.to_string codec v
53
53
+1
-1
ocaml-sbom/test/test_spdx.ml
+1
-1
ocaml-sbom/test/test_spdx.ml
···
1
1
let decode_ok codec s =
2
2
match Json.of_string codec s with
3
3
| Ok v -> v
4
-
| Error e -> Alcotest.failf "decode error: %s" (Json.Error.to_string e)
4
+
| Error e -> Alcotest.failf "decode error: %s" (Loc.Error.to_string e)
5
5
6
6
let roundtrip doc =
7
7
let json = Spdx.to_string doc in
+4
-6
ocaml-scaleway/bin/main.ml
+4
-6
ocaml-scaleway/bin/main.ml
···
592
592
let msg =
593
593
match !oracle_result with
594
594
| Ok _ -> Fmt.str "nghttp (libnghttp2) -- done in %.1fs" !oracle_done_at
595
-
| Error e ->
596
-
Fmt.str "nghttp (libnghttp2) -- failed: %s" (e)
595
+
| Error e -> Fmt.str "nghttp (libnghttp2) -- failed: %s" e
597
596
in
598
597
Tty.Progress.log bar msg
599
598
in
···
612
611
| Ok _ -> Tty.Progress.finish ~message:"ours (ocaml H2) done" bar
613
612
| Error e ->
614
613
Tty.Progress.finish
615
-
~message:
616
-
(Fmt.str "ours (ocaml H2) failed: %s" (e))
614
+
~message:(Fmt.str "ours (ocaml H2) failed: %s" e)
617
615
bar
618
616
in
619
617
Eio.Fiber.all [ run_oracle; run_ours ];
···
759
757
Eio.Switch.run @@ fun sw ->
760
758
match load_profile profile_name config_path with
761
759
| Error e ->
762
-
Fmt.epr "Error: %s@." (e);
760
+
Fmt.epr "Error: %s@." e;
763
761
1
764
762
| Ok p -> (
765
763
let region =
···
783
781
with
784
782
| Ok () -> 0
785
783
| Error e ->
786
-
Fmt.epr "Error: %s@." (e);
784
+
Fmt.epr "Error: %s@." e;
787
785
1)
788
786
in
789
787
let doc =
+1
-2
ocaml-scaleway/lib/scaleway.ml
+1
-2
ocaml-scaleway/lib/scaleway.ml
···
235
235
to_resolved (raw_of_env ())
236
236
| Ok content ->
237
237
let* file =
238
-
Yaml.decode_string (Yaml_json.of_json file_jsont) content
239
-
|> function
238
+
Yaml.decode_string (Yaml_json.of_json file_jsont) content |> function
240
239
| Ok f -> Ok f
241
240
| Error e -> err_parse e
242
241
in
+5
-5
ocaml-scaleway/test/test_scaleway.ml
+5
-5
ocaml-scaleway/test/test_scaleway.ml
···
22
22
let test_flat_profile () =
23
23
scrub_env ();
24
24
match Scaleway.Profile.decode flat_yaml () with
25
-
| Error e -> Alcotest.failf "decode error: %s" (e)
25
+
| Error e -> Alcotest.failf "decode error: %s" e
26
26
| Ok p ->
27
27
Alcotest.(check string) "access" "SCW_AK" p.access_key;
28
28
Alcotest.(check string) "secret" "SCW_SK" p.secret_key;
···
45
45
let test_active_profile () =
46
46
scrub_env ();
47
47
match Scaleway.Profile.decode named_profile_yaml () with
48
-
| Error e -> Alcotest.failf "decode error: %s" (e)
48
+
| Error e -> Alcotest.failf "decode error: %s" e
49
49
| Ok p ->
50
50
Alcotest.(check string) "override access" "SCW_other" p.access_key;
51
51
Alcotest.(check string) "override region" "pl-waw" p.default_region
···
53
53
let test_explicit_name () =
54
54
scrub_env ();
55
55
match Scaleway.Profile.decode named_profile_yaml ~name:"other" () with
56
-
| Error e -> Alcotest.failf "decode error: %s" (e)
56
+
| Error e -> Alcotest.failf "decode error: %s" e
57
57
| Ok p -> Alcotest.(check string) "access" "SCW_other" p.access_key
58
58
59
59
let test_unknown_profile () =
···
82
82
Unix.putenv "SCW_ACCESS_KEY" "ENV_AK";
83
83
Unix.putenv "SCW_DEFAULT_REGION" "pl-waw";
84
84
(match Scaleway.Profile.decode flat_yaml () with
85
-
| Error e -> Alcotest.failf "decode error: %s" (e)
85
+
| Error e -> Alcotest.failf "decode error: %s" e
86
86
| Ok p ->
87
87
Alcotest.(check string) "env wins over file" "ENV_AK" p.access_key;
88
88
Alcotest.(check string) "env region" "pl-waw" p.default_region);
···
95
95
secret_key: S
96
96
|} in
97
97
match Scaleway.Profile.decode yaml () with
98
-
| Error e -> Alcotest.failf "decode error: %s" (e)
98
+
| Error e -> Alcotest.failf "decode error: %s" e
99
99
| Ok p -> Alcotest.(check string) "fallback region" "fr-par" p.default_region
100
100
101
101
let suite =
-1
ocaml-scc/eio/test/dune
-1
ocaml-scc/eio/test/dune
-1
ocaml-scc/fuzz/dune
-1
ocaml-scc/fuzz/dune
+106
-94
ocaml-scitt/lexicons/atp_lexicon_scitt.ml
+106
-94
ocaml-scitt/lexicons/atp_lexicon_scitt.ml
···
2
2
3
3
(** Utility functions for resilient parsing. *)
4
4
module Filter = struct
5
-
(** [filter_list jsont json_list] parses each element with [jsont],
5
+
(** [filter_list codec items] parses each element with [codec],
6
6
returning only successfully parsed elements. Non-compliant records
7
7
are silently skipped. *)
8
-
let filter_list (type a) (jsont : a Json.codec) (json_list : Json.t list) : a list =
9
-
List.filter_map (fun json ->
10
-
match Json.decode jsont json with
11
-
| Ok v -> Some v
12
-
| Error _ -> None
13
-
) json_list
8
+
let filter_list (type a) (codec : a Json.codec) (items : Json.t list)
9
+
: a list =
10
+
List.filter_map
11
+
(fun v ->
12
+
match Json.decode codec v with
13
+
| Ok v -> Some v
14
+
| Error _ -> None)
15
+
items
14
16
end
15
17
16
18
module Com = struct
···
22
24
uri : string;
23
25
}
24
26
25
-
let main_jsont =
26
-
Json.Codec.Object.map ~kind:"Main"
27
-
(fun _typ cid uri -> { cid; uri })
28
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"com.atproto.repo.strongRef" ~enc:(fun _ -> "com.atproto.repo.strongRef")
29
-
|> Json.Codec.Object.mem "cid" Json.Codec.string ~enc:(fun r -> r.cid)
30
-
|> Json.Codec.Object.mem "uri" Json.Codec.string ~enc:(fun r -> r.uri)
31
-
|> Json.Codec.Object.finish
27
+
let main_json : main Json.codec =
28
+
let open Json.Codec in
29
+
Object.map ~kind:"Main"
30
+
(fun _typ cid uri : main -> { cid; uri })
31
+
|> Object.mem "$type" string ~dec_absent:"com.atproto.repo.strongRef" ~enc:(fun _ -> "com.atproto.repo.strongRef")
32
+
|> Object.mem "cid" string ~enc:(fun (r : main) -> r.cid)
33
+
|> Object.mem "uri" string ~enc:(fun (r : main) -> r.uri)
34
+
|> Object.finish
32
35
33
36
end
34
37
end
···
47
50
subject : string;
48
51
}
49
52
50
-
let main_jsont =
51
-
Json.Codec.Object.map ~kind:"Main"
52
-
(fun _typ content_type cose created_at issuer payload_digest subject -> { content_type; cose; created_at; issuer; payload_digest; subject })
53
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"space.run.scitt.statement" ~enc:(fun _ -> "space.run.scitt.statement")
54
-
|> Json.Codec.Object.mem "contentType" Json.Codec.string ~enc:(fun r -> r.content_type)
55
-
|> Json.Codec.Object.mem "cose" Json.Codec.binary_string ~enc:(fun r -> r.cose)
56
-
|> Json.Codec.Object.mem "createdAt" Json.Codec.string ~enc:(fun r -> r.created_at)
57
-
|> Json.Codec.Object.mem "issuer" Json.Codec.string ~enc:(fun r -> r.issuer)
58
-
|> Json.Codec.Object.opt_mem "payloadDigest" Json.Codec.string ~enc:(fun r -> r.payload_digest)
59
-
|> Json.Codec.Object.mem "subject" Json.Codec.string ~enc:(fun r -> r.subject)
60
-
|> Json.Codec.Object.finish
53
+
let main_json : main Json.codec =
54
+
let open Json.Codec in
55
+
Object.map ~kind:"Main"
56
+
(fun _typ content_type cose created_at issuer payload_digest subject : main -> { content_type; cose; created_at; issuer; payload_digest; subject })
57
+
|> Object.mem "$type" string ~dec_absent:"space.run.scitt.statement" ~enc:(fun _ -> "space.run.scitt.statement")
58
+
|> Object.mem "contentType" string ~enc:(fun (r : main) -> r.content_type)
59
+
|> Object.mem "cose" binary_string ~enc:(fun (r : main) -> r.cose)
60
+
|> Object.mem "createdAt" string ~enc:(fun (r : main) -> r.created_at)
61
+
|> Object.mem "issuer" string ~enc:(fun (r : main) -> r.issuer)
62
+
|> Object.opt_mem "payloadDigest" string ~enc:(fun (r : main) -> r.payload_digest)
63
+
|> Object.mem "subject" string ~enc:(fun (r : main) -> r.subject)
64
+
|> Object.finish
61
65
62
66
end
63
67
module RegisterStatement = struct
64
68
type input = unit
65
-
let input_jsont = Json.Codec.ignore
69
+
let input_json = Json.Codec.ignore
66
70
67
71
type output = {
68
72
receipt : string;
···
72
76
tree_size : int;
73
77
}
74
78
75
-
let output_jsont =
76
-
Json.Codec.Object.map ~kind:"Output"
77
-
(fun _typ receipt receipt_uri root statement_uri tree_size -> { receipt; receipt_uri; root; statement_uri; tree_size })
78
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"space.run.scitt.registerStatement#output" ~enc:(fun _ -> "space.run.scitt.registerStatement#output")
79
-
|> Json.Codec.Object.mem "receipt" Json.Codec.binary_string ~enc:(fun r -> r.receipt)
80
-
|> Json.Codec.Object.opt_mem "receiptUri" Json.Codec.string ~enc:(fun r -> r.receipt_uri)
81
-
|> Json.Codec.Object.mem "root" Json.Codec.binary_string ~enc:(fun r -> r.root)
82
-
|> Json.Codec.Object.opt_mem "statementUri" Json.Codec.string ~enc:(fun r -> r.statement_uri)
83
-
|> Json.Codec.Object.mem "treeSize" Json.Codec.int ~enc:(fun r -> r.tree_size)
84
-
|> Json.Codec.Object.finish
79
+
let output_json : output Json.codec =
80
+
let open Json.Codec in
81
+
Object.map ~kind:"Output"
82
+
(fun _typ receipt receipt_uri root statement_uri tree_size : output -> { receipt; receipt_uri; root; statement_uri; tree_size })
83
+
|> Object.mem "$type" string ~dec_absent:"space.run.scitt.registerStatement#output" ~enc:(fun _ -> "space.run.scitt.registerStatement#output")
84
+
|> Object.mem "receipt" binary_string ~enc:(fun (r : output) -> r.receipt)
85
+
|> Object.opt_mem "receiptUri" string ~enc:(fun (r : output) -> r.receipt_uri)
86
+
|> Object.mem "root" binary_string ~enc:(fun (r : output) -> r.root)
87
+
|> Object.opt_mem "statementUri" string ~enc:(fun (r : output) -> r.statement_uri)
88
+
|> Object.mem "treeSize" int ~enc:(fun (r : output) -> r.tree_size)
89
+
|> Object.finish
85
90
86
91
end
87
92
module Receipt = struct
···
94
99
vds_algorithm : int option;
95
100
}
96
101
97
-
let main_jsont =
98
-
Json.Codec.Object.map ~kind:"Main"
99
-
(fun _typ cose created_at root statement tree_size vds_algorithm -> { cose; created_at; root; statement; tree_size; vds_algorithm })
100
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"space.run.scitt.receipt" ~enc:(fun _ -> "space.run.scitt.receipt")
101
-
|> Json.Codec.Object.mem "cose" Json.Codec.binary_string ~enc:(fun r -> r.cose)
102
-
|> Json.Codec.Object.mem "createdAt" Json.Codec.string ~enc:(fun r -> r.created_at)
103
-
|> Json.Codec.Object.mem "root" Json.Codec.binary_string ~enc:(fun r -> r.root)
104
-
|> Json.Codec.Object.mem "statement" Com.Atproto.Repo.StrongRef.main_jsont ~enc:(fun r -> r.statement)
105
-
|> Json.Codec.Object.opt_mem "treeSize" Json.Codec.int ~enc:(fun r -> r.tree_size)
106
-
|> Json.Codec.Object.opt_mem "vdsAlgorithm" Json.Codec.int ~enc:(fun r -> r.vds_algorithm)
107
-
|> Json.Codec.Object.finish
102
+
let main_json : main Json.codec =
103
+
let open Json.Codec in
104
+
Object.map ~kind:"Main"
105
+
(fun _typ cose created_at root statement tree_size vds_algorithm : main -> { cose; created_at; root; statement; tree_size; vds_algorithm })
106
+
|> Object.mem "$type" string ~dec_absent:"space.run.scitt.receipt" ~enc:(fun _ -> "space.run.scitt.receipt")
107
+
|> Object.mem "cose" binary_string ~enc:(fun (r : main) -> r.cose)
108
+
|> Object.mem "createdAt" string ~enc:(fun (r : main) -> r.created_at)
109
+
|> Object.mem "root" binary_string ~enc:(fun (r : main) -> r.root)
110
+
|> Object.mem "statement" Com.Atproto.Repo.StrongRef.main_json ~enc:(fun (r : main) -> r.statement)
111
+
|> Object.opt_mem "treeSize" int ~enc:(fun (r : main) -> r.tree_size)
112
+
|> Object.opt_mem "vdsAlgorithm" int ~enc:(fun (r : main) -> r.vds_algorithm)
113
+
|> Object.finish
108
114
109
115
end
110
116
module Defs = struct
···
115
121
root : string;
116
122
}
117
123
118
-
let inclusion_proof_jsont =
119
-
Json.Codec.Object.map ~kind:"Inclusion_proof"
120
-
(fun _typ index leaf_hash path root -> { index; leaf_hash; path; root })
121
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"space.run.scitt.defs#inclusionProof" ~enc:(fun _ -> "space.run.scitt.defs#inclusionProof")
122
-
|> Json.Codec.Object.mem "index" Json.Codec.string ~enc:(fun r -> r.index)
123
-
|> Json.Codec.Object.mem "leafHash" Json.Codec.binary_string ~enc:(fun r -> r.leaf_hash)
124
-
|> Json.Codec.Object.mem "path" (Json.Codec.list Json.Codec.binary_string) ~enc:(fun r -> r.path)
125
-
|> Json.Codec.Object.mem "root" Json.Codec.binary_string ~enc:(fun r -> r.root)
126
-
|> Json.Codec.Object.finish
124
+
let inclusion_proof_json : inclusion_proof Json.codec =
125
+
let open Json.Codec in
126
+
Object.map ~kind:"Inclusion_proof"
127
+
(fun _typ index leaf_hash path root : inclusion_proof -> { index; leaf_hash; path; root })
128
+
|> Object.mem "$type" string ~dec_absent:"space.run.scitt.defs#inclusionProof" ~enc:(fun _ -> "space.run.scitt.defs#inclusionProof")
129
+
|> Object.mem "index" string ~enc:(fun (r : inclusion_proof) -> r.index)
130
+
|> Object.mem "leafHash" binary_string ~enc:(fun (r : inclusion_proof) -> r.leaf_hash)
131
+
|> Object.mem "path" (list binary_string) ~enc:(fun (r : inclusion_proof) -> r.path)
132
+
|> Object.mem "root" binary_string ~enc:(fun (r : inclusion_proof) -> r.root)
133
+
|> Object.finish
127
134
128
135
type transparent_statement = {
129
136
receipts : string list;
130
137
statement : string;
131
138
}
132
139
133
-
let transparent_statement_jsont =
134
-
Json.Codec.Object.map ~kind:"Transparent_statement"
135
-
(fun _typ receipts statement -> { receipts; statement })
136
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"space.run.scitt.defs#transparentStatement" ~enc:(fun _ -> "space.run.scitt.defs#transparentStatement")
137
-
|> Json.Codec.Object.mem "receipts" (Json.Codec.list Json.Codec.binary_string) ~enc:(fun r -> r.receipts)
138
-
|> Json.Codec.Object.mem "statement" Json.Codec.binary_string ~enc:(fun r -> r.statement)
139
-
|> Json.Codec.Object.finish
140
+
let transparent_statement_json : transparent_statement Json.codec =
141
+
let open Json.Codec in
142
+
Object.map ~kind:"Transparent_statement"
143
+
(fun _typ receipts statement : transparent_statement -> { receipts; statement })
144
+
|> Object.mem "$type" string ~dec_absent:"space.run.scitt.defs#transparentStatement" ~enc:(fun _ -> "space.run.scitt.defs#transparentStatement")
145
+
|> Object.mem "receipts" (list binary_string) ~enc:(fun (r : transparent_statement) -> r.receipts)
146
+
|> Object.mem "statement" binary_string ~enc:(fun (r : transparent_statement) -> r.statement)
147
+
|> Object.finish
140
148
141
149
end
142
150
module GetStatement = struct
···
145
153
uri : string option;
146
154
}
147
155
148
-
let params_jsont =
149
-
Json.Codec.Object.map ~kind:"Params"
150
-
(fun subject uri -> {
156
+
let params_json : params Json.codec =
157
+
let open Json.Codec in
158
+
Object.map ~kind:"Params"
159
+
(fun subject uri : params -> {
151
160
subject;
152
161
uri;
153
162
})
154
-
|> Json.Codec.Object.opt_mem "subject" Json.Codec.string
155
-
~enc:(fun r -> r.subject)
156
-
|> Json.Codec.Object.opt_mem "uri" Json.Codec.string
157
-
~enc:(fun r -> r.uri)
158
-
|> Json.Codec.Object.finish
163
+
|> Object.opt_mem "subject" string
164
+
~enc:(fun (r : params) -> r.subject)
165
+
|> Object.opt_mem "uri" string
166
+
~enc:(fun (r : params) -> r.uri)
167
+
|> Object.finish
159
168
160
169
type output = {
161
170
receipt : Receipt.main option;
···
163
172
transparent_statement : Defs.transparent_statement option;
164
173
}
165
174
166
-
let output_jsont =
167
-
Json.Codec.Object.map ~kind:"Output"
168
-
(fun _typ receipt statement transparent_statement -> { receipt; statement; transparent_statement })
169
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"space.run.scitt.getStatement#output" ~enc:(fun _ -> "space.run.scitt.getStatement#output")
170
-
|> Json.Codec.Object.opt_mem "receipt" Receipt.main_jsont ~enc:(fun r -> r.receipt)
171
-
|> Json.Codec.Object.mem "statement" Statement.main_jsont ~enc:(fun r -> r.statement)
172
-
|> Json.Codec.Object.opt_mem "transparentStatement" Defs.transparent_statement_jsont ~enc:(fun r -> r.transparent_statement)
173
-
|> Json.Codec.Object.finish
175
+
let output_json : output Json.codec =
176
+
let open Json.Codec in
177
+
Object.map ~kind:"Output"
178
+
(fun _typ receipt statement transparent_statement : output -> { receipt; statement; transparent_statement })
179
+
|> Object.mem "$type" string ~dec_absent:"space.run.scitt.getStatement#output" ~enc:(fun _ -> "space.run.scitt.getStatement#output")
180
+
|> Object.opt_mem "receipt" Receipt.main_json ~enc:(fun (r : output) -> r.receipt)
181
+
|> Object.mem "statement" Statement.main_json ~enc:(fun (r : output) -> r.statement)
182
+
|> Object.opt_mem "transparentStatement" Defs.transparent_statement_json ~enc:(fun (r : output) -> r.transparent_statement)
183
+
|> Object.finish
174
184
175
185
end
176
186
module GetReceipt = struct
···
179
189
uri : string option;
180
190
}
181
191
182
-
let params_jsont =
183
-
Json.Codec.Object.map ~kind:"Params"
184
-
(fun statement uri -> {
192
+
let params_json : params Json.codec =
193
+
let open Json.Codec in
194
+
Object.map ~kind:"Params"
195
+
(fun statement uri : params -> {
185
196
statement;
186
197
uri;
187
198
})
188
-
|> Json.Codec.Object.opt_mem "statement" Json.Codec.string
189
-
~enc:(fun r -> r.statement)
190
-
|> Json.Codec.Object.opt_mem "uri" Json.Codec.string
191
-
~enc:(fun r -> r.uri)
192
-
|> Json.Codec.Object.finish
199
+
|> Object.opt_mem "statement" string
200
+
~enc:(fun (r : params) -> r.statement)
201
+
|> Object.opt_mem "uri" string
202
+
~enc:(fun (r : params) -> r.uri)
203
+
|> Object.finish
193
204
194
205
type output = {
195
206
inclusion_proof : Defs.inclusion_proof option;
196
207
receipt : Receipt.main;
197
208
}
198
209
199
-
let output_jsont =
200
-
Json.Codec.Object.map ~kind:"Output"
201
-
(fun _typ inclusion_proof receipt -> { inclusion_proof; receipt })
202
-
|> Json.Codec.Object.mem "$type" Json.Codec.string ~dec_absent:"space.run.scitt.getReceipt#output" ~enc:(fun _ -> "space.run.scitt.getReceipt#output")
203
-
|> Json.Codec.Object.opt_mem "inclusionProof" Defs.inclusion_proof_jsont ~enc:(fun r -> r.inclusion_proof)
204
-
|> Json.Codec.Object.mem "receipt" Receipt.main_jsont ~enc:(fun r -> r.receipt)
205
-
|> Json.Codec.Object.finish
210
+
let output_json : output Json.codec =
211
+
let open Json.Codec in
212
+
Object.map ~kind:"Output"
213
+
(fun _typ inclusion_proof receipt : output -> { inclusion_proof; receipt })
214
+
|> Object.mem "$type" string ~dec_absent:"space.run.scitt.getReceipt#output" ~enc:(fun _ -> "space.run.scitt.getReceipt#output")
215
+
|> Object.opt_mem "inclusionProof" Defs.inclusion_proof_json ~enc:(fun (r : output) -> r.inclusion_proof)
216
+
|> Object.mem "receipt" Receipt.main_json ~enc:(fun (r : output) -> r.receipt)
217
+
|> Object.finish
206
218
207
219
end
208
220
end
+12
-12
ocaml-scitt/lexicons/atp_lexicon_scitt.mli
+12
-12
ocaml-scitt/lexicons/atp_lexicon_scitt.mli
···
5
5
(** Utility functions for resilient parsing. *)
6
6
module Filter : sig
7
7
val filter_list : 'a Json.codec -> Json.t list -> 'a list
8
-
(** [filter_list jsont json_list] parses each element with [jsont],
8
+
(** [filter_list json json_list] parses each element with [json],
9
9
returning only successfully parsed elements. Non-compliant records
10
10
are silently skipped. *)
11
11
end
···
22
22
}
23
23
24
24
(** Jsont codec for {!type:main}. *)
25
-
val main_jsont : main Json.codec
25
+
val main_json : main Json.codec
26
26
27
27
end
28
28
end
···
44
44
}
45
45
46
46
(** Jsont codec for {!type:main}. *)
47
-
val main_jsont : main Json.codec
47
+
val main_json : main Json.codec
48
48
49
49
end
50
50
module RegisterStatement : sig
···
53
53
(** COSE_Sign1 encoded signed statement. *)
54
54
55
55
type input = unit
56
-
val input_jsont : input Json.codec
56
+
val input_json : input Json.codec
57
57
58
58
59
59
type output = {
···
65
65
}
66
66
67
67
(** Jsont codec for {!type:output}. *)
68
-
val output_jsont : output Json.codec
68
+
val output_json : output Json.codec
69
69
70
70
end
71
71
module Receipt : sig
···
81
81
}
82
82
83
83
(** Jsont codec for {!type:main}. *)
84
-
val main_jsont : main Json.codec
84
+
val main_json : main Json.codec
85
85
86
86
end
87
87
module Defs : sig
···
95
95
}
96
96
97
97
(** Jsont codec for {!type:inclusion_proof}. *)
98
-
val inclusion_proof_jsont : inclusion_proof Json.codec
98
+
val inclusion_proof_json : inclusion_proof Json.codec
99
99
100
100
(** A signed statement bundled with its receipts — everything needed for offline verification. *)
101
101
···
105
105
}
106
106
107
107
(** Jsont codec for {!type:transparent_statement}. *)
108
-
val transparent_statement_jsont : transparent_statement Json.codec
108
+
val transparent_statement_json : transparent_statement Json.codec
109
109
110
110
end
111
111
module GetStatement : sig
···
118
118
}
119
119
120
120
(** Jsont codec for {!type:params}. *)
121
-
val params_jsont : params Json.codec
121
+
val params_json : params Json.codec
122
122
123
123
124
124
type output = {
···
128
128
}
129
129
130
130
(** Jsont codec for {!type:output}. *)
131
-
val output_jsont : output Json.codec
131
+
val output_json : output Json.codec
132
132
133
133
end
134
134
module GetReceipt : sig
···
141
141
}
142
142
143
143
(** Jsont codec for {!type:params}. *)
144
-
val params_jsont : params Json.codec
144
+
val params_json : params Json.codec
145
145
146
146
147
147
type output = {
···
150
150
}
151
151
152
152
(** Jsont codec for {!type:output}. *)
153
-
val output_jsont : output Json.codec
153
+
val output_json : output Json.codec
154
154
155
155
end
156
156
end
+1
-1
ocaml-scitt/lib/atp/scitt_atp.ml
+1
-1
ocaml-scitt/lib/atp/scitt_atp.ml
···
110
110
| None -> String.make 32 '\x00'
111
111
112
112
let err_duplicate key = Error ("duplicate key: " ^ key)
113
-
let err_encoding e = Error ("encoding error: " ^ Json.Error.to_string e)
113
+
let err_encoding e = Error ("encoding error: " ^ e)
114
114
115
115
let repo_key_of_vds_key key =
116
116
match String.index_opt key '/' with
+1
-1
ocaml-scitt/lib/vds.ml
+1
-1
ocaml-scitt/lib/vds.ml
···
617
617
| (key, value) :: rest -> (
618
618
match append vds ~key ~value with
619
619
| Ok _ -> go rest
620
-
| Error e -> Error ("import: " ^ Json.Error.to_string e))
620
+
| Error e -> Error ("import: " ^ e))
621
621
in
622
622
let* () = go entries in
623
623
(* Verify root integrity if present in export *)
+1
-1
ocaml-scitt/test/test_scitt.ml
+1
-1
ocaml-scitt/test/test_scitt.ml
···
1337
1337
let decode_key_exn hex =
1338
1338
match X509.Public_key.decode_der (hex_to_raw hex) with
1339
1339
| Ok k -> k
1340
-
| Error (`Msg e) -> Alcotest.failf "decode key: %s" (Json.Error.to_string e)
1340
+
| Error (`Msg e) -> Alcotest.failf "decode key: %s" e
1341
1341
1342
1342
let test_roundtrip_decode_verify () =
1343
1343
let transparent_bytes = hex_to_raw interop_transparent_hex in
+1
-1
ocaml-scitt/test/test_vds.ml
+1
-1
ocaml-scitt/test/test_vds.ml
···
43
43
Scitt.Vds_rfc9162.import exported ~create:(fun ~hash () ->
44
44
Scitt.Vds_rfc9162.in_memory ~hash ())
45
45
with
46
-
| Error e -> Alcotest.failf "import failed: %s" (Json.Error.to_string e)
46
+
| Error e -> Alcotest.failf "import failed: %s" e
47
47
| Ok imported ->
48
48
Alcotest.(check int)
49
49
"size preserved" original_size (Scitt.vds_size imported);
-1
ocaml-sdls/c/dune
-1
ocaml-sdls/c/dune
-1
ocaml-sdls/fuzz/dune
-1
ocaml-sdls/fuzz/dune
-1
ocaml-sdnv/fuzz/dune
-1
ocaml-sdnv/fuzz/dune
+10
-58
ocaml-sexp/lib/codec.ml
+10
-58
ocaml-sexp/lib/codec.ml
···
10
10
module Path = Loc.Path
11
11
module Error = Loc.Error
12
12
13
-
exception Error = Loc.Error
14
-
15
-
(* ---- Sort ---- *)
16
-
17
-
module Sort = struct
18
-
type t = Atom | List
19
-
20
-
let to_string = function Atom -> "atom" | List -> "list"
21
-
let pp fmt t = Fmt.string fmt (to_string t)
22
-
let of_sexp : Value.t -> t = function Atom _ -> Atom | List _ -> List
23
-
24
-
let kinded ~kind s =
25
-
if kind = "" then to_string s else String.concat " " [ kind; to_string s ]
26
-
27
-
let or_kind ~kind s = if kind <> "" then kind else to_string s
28
-
end
29
-
30
13
(* ---- Error/context helpers ---- *)
31
14
32
15
let meta_none = Meta.none
···
34
17
let err_expected_got ?(meta = meta_none) expected got =
35
18
Error.failf meta "expected %s, got %s" expected got
36
19
37
-
(* Wrap a decode step so any [Loc.Error] raised inside picks up an
38
-
extra context frame. Record kind uses Sort.kinded so a "record" or
39
-
user-supplied kind appears alongside the [Sort.List] tag. *)
20
+
(* Tag for record/list-context error messages. The codec only emits "list" sorts
21
+
in error context (records are encoded as alists), so the tag is a fixed
22
+
string; callers may prepend a user-supplied kind. *)
23
+
let kinded_list ~kind =
24
+
if kind = "" then "list" else String.concat " " [ kind; "list" ]
25
+
26
+
(* Wrap a decode step so any [Loc.Error] raised inside picks up an extra
27
+
context frame. *)
40
28
let push_mem_ctx kind_node name_node f =
41
29
try f () with Loc.Error e -> Error.push_object kind_node name_node e
42
30
43
31
let push_nth_ctx kind_node idx_node f =
44
32
try f () with Loc.Error e -> Error.push_array kind_node idx_node e
45
33
46
-
let record_kind_node kind =
47
-
let k = Sort.kinded ~kind Sort.List in
48
-
(k, Meta.none)
49
-
50
-
let list_kind_node kind =
51
-
let k = Sort.kinded ~kind Sort.List in
52
-
(k, Meta.none)
34
+
let record_kind_node kind = (kinded_list ~kind, Meta.none)
35
+
let list_kind_node kind = (kinded_list ~kind, Meta.none)
53
36
54
37
(* ---- Type helpers ---- *)
55
38
···
803
786
(* ---- Record ts (using alist-style sexps) ---- *)
804
787
805
788
module Record = struct
806
-
module Mem = struct
807
-
type ('o, 'a) map = {
808
-
name : string;
809
-
mem_doc : string;
810
-
mem_codec : 'a t;
811
-
dec_absent : 'a option;
812
-
enc : ('o -> 'a) option;
813
-
enc_omit : ('a -> bool) option;
814
-
}
815
-
816
-
let map ?doc ?(dec_absent : 'a option) ?enc ?enc_omit name (codec : 'a t) =
817
-
{
818
-
name;
819
-
mem_doc = Option.value ~default:"" doc;
820
-
mem_codec = codec;
821
-
dec_absent;
822
-
enc;
823
-
enc_omit;
824
-
}
825
-
826
-
let opt ?doc ?enc name (codec : 'a t) =
827
-
{
828
-
name;
829
-
mem_doc = Option.value ~default:"" doc;
830
-
mem_codec = option codec;
831
-
dec_absent = Some None;
832
-
enc;
833
-
enc_omit = Some Option.is_none;
834
-
}
835
-
end
836
-
837
789
type ('o, 'dec) map = {
838
790
map_kind : string;
839
791
map_doc : string;
-24
ocaml-sexp/lib/codec.mli
-24
ocaml-sexp/lib/codec.mli
···
114
114
115
115
(** Record builder. *)
116
116
module Record : sig
117
-
(** Member specifications. *)
118
-
module Mem : sig
119
-
type ('o, 'a) map
120
-
(** Member of type ['a] in record ['o]. *)
121
-
122
-
val map :
123
-
?doc:string ->
124
-
?dec_absent:'a ->
125
-
?enc:('o -> 'a) ->
126
-
?enc_omit:('a -> bool) ->
127
-
string ->
128
-
'a t ->
129
-
('o, 'a) map
130
-
(** [map name c] creates a member. *)
131
-
132
-
val opt :
133
-
?doc:string ->
134
-
?enc:('o -> 'a option) ->
135
-
string ->
136
-
'a t ->
137
-
('o, 'a option) map
138
-
(** [opt name c] creates an optional member. *)
139
-
end
140
-
141
117
type ('o, 'dec) map
142
118
(** Record builder state. *)
143
119
-1
ocaml-sexp/test/codecs/dune
-1
ocaml-sexp/test/codecs/dune
-1
ocaml-sexp/test/dune
-1
ocaml-sexp/test/dune
-1
ocaml-sgp4/fuzz/dune
-1
ocaml-sgp4/fuzz/dune
-1
ocaml-short-ldpc/fuzz/dune
-1
ocaml-short-ldpc/fuzz/dune
-1
ocaml-sigstore/lib/dune
-1
ocaml-sigstore/lib/dune
+6
-20
ocaml-sigstore/lib/sigstore.ml
+6
-20
ocaml-sigstore/lib/sigstore.ml
···
151
151
let none = Json.Meta.none
152
152
153
153
let json_of_string s =
154
-
Json_bytesrw.decode_string Json.json s
155
-
|> Result.map_error (fun e -> Fmt.str "%s" e)
156
-
157
-
let json_to_string json =
158
-
Json_bytesrw.encode_string ~format:Json.Minify Json.json json
159
-
|> Result.map_error (fun e -> Fmt.str "%s" e)
154
+
Json.Value.of_string s |> Result.map_error Json.Error.to_string
160
155
156
+
let json_to_string json = Json.Value.to_string ~format:Json.Minify json
161
157
let json_str s = Json.String (s, none)
162
158
let json_num n = Json.Number (n, none)
163
159
···
168
164
169
165
(** Find a member by name in a JSON object's member list. *)
170
166
let lookup name (mems : Json.object') =
171
-
match Json.Value.find_mem name mems with
172
-
| Some (_, v) -> Some v
173
-
| None -> None
167
+
match Json.find_mem name mems with Some (_, v) -> Some v | None -> None
174
168
175
169
(** Extract a string from a JSON value. *)
176
170
let string_v = function Json.String (s, _) -> Some s | _ -> None
···
347
341
] );
348
342
]
349
343
in
350
-
let body =
351
-
match json_to_string body_json with
352
-
| Ok s -> s
353
-
| Error e -> Fmt.failwith "JSON encode failed: %s" e
354
-
in
344
+
let body = json_to_string body_json in
355
345
let headers =
356
346
Requests.Headers.empty
357
347
|> Requests.Headers.add_string "Accept"
···
443
433
] );
444
434
]
445
435
in
446
-
let body =
447
-
match json_to_string body_json with
448
-
| Ok s -> s
449
-
| Error e -> Fmt.failwith "JSON encode failed: %s" e
450
-
in
436
+
let body = json_to_string body_json in
451
437
let headers = Requests.Headers.empty in
452
438
let resp = post_json session url ~headers body in
453
439
match check_response resp with
···
778
764
let verify_bundle_common ?anchors ~now bundle =
779
765
match bundle.verification_material.certificate_chain with
780
766
| [] -> Error (Verification_failed "no certificates in bundle")
781
-
| leaf_pem :: _ as all_pems -> (
767
+
| _ :: _ as all_pems -> (
782
768
match decode_chain all_pems with
783
769
| Error _ as e -> e
784
770
| Ok [] -> Error (Verification_failed "empty chain after decoding")
+1
-1
ocaml-slack/bin/login.ml
+1
-1
ocaml-slack/bin/login.ml
···
187
187
| None -> Error "No access token in response"))
188
188
| Ok r -> Error (Option.value ~default:"unknown error" r.error)
189
189
| Error e ->
190
-
let msg = "JSON parse error: " ^ Json.Error.to_string e in
190
+
let msg = "JSON parse error: " ^ e in
191
191
Error msg
192
192
193
193
(** {1 Default user scopes} *)
-1
ocaml-sle/fuzz/dune
-1
ocaml-sle/fuzz/dune
-1
ocaml-space-packet/c/dune
-1
ocaml-space-packet/c/dune
-1
ocaml-space-packet/fuzz/dune
-1
ocaml-space-packet/fuzz/dune
+1
-2
ocaml-spacedata/dune-project
+1
-2
ocaml-spacedata/dune-project
+1
-1
ocaml-spacedata/lib/dune
+1
-1
ocaml-spacedata/lib/dune
+37
-34
ocaml-spacedata/lib/spacedata.ml
+37
-34
ocaml-spacedata/lib/spacedata.ml
···
30
30
Both return numbers as strings in JSON. *)
31
31
32
32
(* GP element sets can have numeric fields as either JSON numbers or
33
-
JSON strings depending on the source. We accept both via Jsont.any. *)
33
+
JSON strings depending on the source. We accept both via Json.Codec.any. *)
34
34
35
35
let float_of_string_jsont =
36
-
Jsont.map ~kind:"float_of_string"
36
+
Json.Codec.map ~kind:"float_of_string"
37
37
~dec:(fun s -> match float_of_string_opt s with Some f -> f | None -> 0.0)
38
-
~enc:string_of_float Jsont.string
38
+
~enc:string_of_float Json.Codec.string
39
39
40
40
let int_of_string_jsont =
41
-
Jsont.map ~kind:"int_of_string"
41
+
Json.Codec.map ~kind:"int_of_string"
42
42
~dec:(fun s -> match int_of_string_opt s with Some i -> i | None -> 0)
43
-
~enc:string_of_int Jsont.string
43
+
~enc:string_of_int Json.Codec.string
44
44
45
45
let flexible_float =
46
-
Jsont.any ~kind:"flexible_float" ~dec_number:Jsont.number
46
+
Json.Codec.any ~kind:"flexible_float" ~dec_number:Json.Codec.number
47
47
~dec_string:float_of_string_jsont
48
-
~enc:(fun _ -> Jsont.number)
48
+
~enc:(fun _ -> Json.Codec.number)
49
49
()
50
50
51
51
let flexible_int =
52
-
Jsont.any ~kind:"flexible_int" ~dec_number:Jsont.int
52
+
Json.Codec.any ~kind:"flexible_int" ~dec_number:Json.Codec.int
53
53
~dec_string:int_of_string_jsont
54
-
~enc:(fun _ -> Jsont.int)
54
+
~enc:(fun _ -> Json.Codec.int)
55
55
()
56
56
57
57
let gp_jsont =
···
76
76
tle_line2;
77
77
}
78
78
in
79
-
Jsont.Object.map ~kind:"gp" make
80
-
|> Jsont.Object.mem "NORAD_CAT_ID" flexible_int ~enc:(fun g -> g.norad_cat_id)
81
-
|> Jsont.Object.mem "OBJECT_NAME" Jsont.string ~enc:(fun g -> g.object_name)
82
-
|> Jsont.Object.mem "OBJECT_ID" Jsont.string ~dec_absent:"" ~enc:(fun g ->
83
-
g.object_id)
84
-
|> Jsont.Object.mem "EPOCH" Jsont.string ~enc:(fun g -> g.epoch)
85
-
|> Jsont.Object.mem "MEAN_MOTION" flexible_float ~enc:(fun g -> g.mean_motion)
86
-
|> Jsont.Object.mem "ECCENTRICITY" flexible_float ~enc:(fun g ->
79
+
Json.Codec.Object.map ~kind:"gp" make
80
+
|> Json.Codec.Object.mem "NORAD_CAT_ID" flexible_int ~enc:(fun g ->
81
+
g.norad_cat_id)
82
+
|> Json.Codec.Object.mem "OBJECT_NAME" Json.Codec.string ~enc:(fun g ->
83
+
g.object_name)
84
+
|> Json.Codec.Object.mem "OBJECT_ID" Json.Codec.string ~dec_absent:""
85
+
~enc:(fun g -> g.object_id)
86
+
|> Json.Codec.Object.mem "EPOCH" Json.Codec.string ~enc:(fun g -> g.epoch)
87
+
|> Json.Codec.Object.mem "MEAN_MOTION" flexible_float ~enc:(fun g ->
88
+
g.mean_motion)
89
+
|> Json.Codec.Object.mem "ECCENTRICITY" flexible_float ~enc:(fun g ->
87
90
g.eccentricity)
88
-
|> Jsont.Object.mem "INCLINATION" flexible_float ~enc:(fun g -> g.inclination)
89
-
|> Jsont.Object.mem "RA_OF_ASC_NODE" flexible_float ~enc:(fun g ->
91
+
|> Json.Codec.Object.mem "INCLINATION" flexible_float ~enc:(fun g ->
92
+
g.inclination)
93
+
|> Json.Codec.Object.mem "RA_OF_ASC_NODE" flexible_float ~enc:(fun g ->
90
94
g.ra_of_asc_node)
91
-
|> Jsont.Object.mem "ARG_OF_PERICENTER" flexible_float ~enc:(fun g ->
95
+
|> Json.Codec.Object.mem "ARG_OF_PERICENTER" flexible_float ~enc:(fun g ->
92
96
g.arg_of_pericenter)
93
-
|> Jsont.Object.mem "MEAN_ANOMALY" flexible_float ~enc:(fun g ->
97
+
|> Json.Codec.Object.mem "MEAN_ANOMALY" flexible_float ~enc:(fun g ->
94
98
g.mean_anomaly)
95
-
|> Jsont.Object.mem "BSTAR" flexible_float ~enc:(fun g -> g.bstar)
96
-
|> Jsont.Object.mem "ELEMENT_SET_NO" flexible_int ~dec_absent:0 ~enc:(fun g ->
97
-
g.element_set_no)
98
-
|> Jsont.Object.mem "REV_AT_EPOCH" flexible_int ~dec_absent:0 ~enc:(fun g ->
99
-
g.rev_at_epoch)
100
-
|> Jsont.Object.mem "TLE_LINE1" Jsont.string ~dec_absent:"" ~enc:(fun g ->
101
-
g.tle_line1)
102
-
|> Jsont.Object.mem "TLE_LINE2" Jsont.string ~dec_absent:"" ~enc:(fun g ->
103
-
g.tle_line2)
104
-
|> Jsont.Object.finish
99
+
|> Json.Codec.Object.mem "BSTAR" flexible_float ~enc:(fun g -> g.bstar)
100
+
|> Json.Codec.Object.mem "ELEMENT_SET_NO" flexible_int ~dec_absent:0
101
+
~enc:(fun g -> g.element_set_no)
102
+
|> Json.Codec.Object.mem "REV_AT_EPOCH" flexible_int ~dec_absent:0
103
+
~enc:(fun g -> g.rev_at_epoch)
104
+
|> Json.Codec.Object.mem "TLE_LINE1" Json.Codec.string ~dec_absent:""
105
+
~enc:(fun g -> g.tle_line1)
106
+
|> Json.Codec.Object.mem "TLE_LINE2" Json.Codec.string ~dec_absent:""
107
+
~enc:(fun g -> g.tle_line2)
108
+
|> Json.Codec.Object.finish
105
109
106
110
let pp_gp ppf gp =
107
111
Fmt.pf ppf "%s [%d] %s" gp.object_name gp.norad_cat_id gp.epoch
108
112
109
-
let gp_list_jsont = Jsont.list gp_jsont
110
113
let deg2rad x = x *. Float.pi /. 180.0
111
114
112
115
(* Parse epoch string into (2-digit year, day-of-year with fractional day).
···
158
161
in
159
162
let resp = Requests.Response.raise_for_status resp in
160
163
let body = Requests.Response.text resp in
161
-
match Jsont_bytesrw.decode_string (Jsont.list codec) body with
164
+
match Json.of_string (Json.Codec.list codec) body with
162
165
| Ok v -> v
163
-
| Error e -> Fmt.failwith "JSON decode error: %s" e
166
+
| Error e -> Fmt.failwith "JSON decode error: %s" (Json.Error.to_string e)
164
167
165
168
(* {1 CelesTrak} *)
166
169
+1
-1
ocaml-spacedata/lib/spacedata.mli
+1
-1
ocaml-spacedata/lib/spacedata.mli
+1
-1
ocaml-spacedata/spacedata.opam
+1
-1
ocaml-spacedata/spacedata.opam
+1
-10
ocaml-spacedata/test/dune
+1
-10
ocaml-spacedata/test/dune
+7
-14
ocaml-spacedata/test/test_spacedata.ml
+7
-14
ocaml-spacedata/test/test_spacedata.ml
···
73
73
74
74
let test_parse_gp_json () =
75
75
let gps =
76
-
Jsont_bytesrw.decode_string (Jsont.list Spacedata.gp_jsont) iss_gp_json
76
+
Json.of_string (Json.Codec.list Spacedata.gp_jsont) iss_gp_json
77
77
|> Result.get_ok
78
78
in
79
79
Alcotest.(check int) "count" 1 (List.length gps);
···
89
89
90
90
let test_parse_numeric_fields () =
91
91
let gps =
92
-
Jsont_bytesrw.decode_string
93
-
(Jsont.list Spacedata.gp_jsont)
94
-
iss_gp_json_numeric
92
+
Json.of_string (Json.Codec.list Spacedata.gp_jsont) iss_gp_json_numeric
95
93
|> Result.get_ok
96
94
in
97
95
let gp = List.hd gps in
···
100
98
101
99
let test_parse_extra_fields () =
102
100
let gps =
103
-
Jsont_bytesrw.decode_string
104
-
(Jsont.list Spacedata.gp_jsont)
105
-
gp_json_extra_fields
101
+
Json.of_string (Json.Codec.list Spacedata.gp_jsont) gp_json_extra_fields
106
102
|> Result.get_ok
107
103
in
108
104
let gp = List.hd gps in
···
111
107
112
108
let test_gp_to_tle () =
113
109
let gps =
114
-
Jsont_bytesrw.decode_string (Jsont.list Spacedata.gp_jsont) iss_gp_json
110
+
Json.of_string (Json.Codec.list Spacedata.gp_jsont) iss_gp_json
115
111
|> Result.get_ok
116
112
in
117
113
let gp = List.hd gps in
···
126
122
(* GP without TLE lines should still produce a valid TLE from elements *)
127
123
let gp_to_tle_elements () =
128
124
let gps =
129
-
Jsont_bytesrw.decode_string
130
-
(Jsont.list Spacedata.gp_jsont)
131
-
gp_json_extra_fields
125
+
Json.of_string (Json.Codec.list Spacedata.gp_jsont) gp_json_extra_fields
132
126
|> Result.get_ok
133
127
in
134
128
let gp = List.hd gps in
···
153
147
(* Parse ISS GP, convert to TLE, run SGP4 — same pipeline as a live
154
148
fetch but without network I/O. *)
155
149
let gps =
156
-
Jsont_bytesrw.decode_string (Jsont.list Spacedata.gp_jsont) iss_gp_json
150
+
Json.of_string (Json.Codec.list Spacedata.gp_jsont) iss_gp_json
157
151
|> Result.get_ok
158
152
in
159
153
let gp = List.hd gps in
···
212
206
}]|}
213
207
in
214
208
let gps =
215
-
Jsont_bytesrw.decode_string (Jsont.list Spacedata.gp_jsont) extra
216
-
|> Result.get_ok
209
+
Json.of_string (Json.Codec.list Spacedata.gp_jsont) extra |> Result.get_ok
217
210
in
218
211
Alcotest.(check int) "two entries" 2 (List.length gps);
219
212
Alcotest.(check string) "first" "ISS (ZARYA)" (List.hd gps).object_name;
-1
ocaml-spacefibre/c/dune
-1
ocaml-spacefibre/c/dune
-1
ocaml-spacefibre/fuzz/dune
-1
ocaml-spacefibre/fuzz/dune
-2
ocaml-spacefibre/test/test_crc32.ml
-2
ocaml-spacefibre/test/test_crc32.ml
···
3
3
CRC-32 uses the standard IEEE 802.3 polynomial (0x04C11DB7, reflected). Test
4
4
vectors are from well-known sources. *)
5
5
6
-
let int32 = Alcotest.testable (fun ppf v -> Fmt.pf ppf "0x%08lX" v) Int32.equal
7
-
8
6
(* Known CRC-32 test vectors. *)
9
7
let test_crc_known_values () =
10
8
(* CRC of empty string *)
-1
ocaml-spacewire/c/dune
-1
ocaml-spacewire/c/dune
-1
ocaml-spacewire/fuzz/dune
-1
ocaml-spacewire/fuzz/dune
-1
ocaml-spake2/fuzz/dune
-1
ocaml-spake2/fuzz/dune
-1
ocaml-sqlite/fuzz/dune
-1
ocaml-sqlite/fuzz/dune
+5
-18
ocaml-sqlite/lib/sqlite.ml
+5
-18
ocaml-sqlite/lib/sqlite.ml
···
55
55
type generic_table = {
56
56
g_btree : Btree.Table.t;
57
57
g_schema : schema;
58
-
mutable g_unique_indexes : unique_index list;
58
+
g_unique_indexes : unique_index list;
59
59
}
60
60
61
61
(* Raw sqlite_master entry for schema objects we don't manage (views,
···
73
73
file : Eio.File.rw_ty Eio.Resource.t option;
74
74
mutable sw : Eio.Switch.t option;
75
75
db_path : Eio.Fs.dir_ty Eio.Path.t option;
76
-
mutable data : kv_table option;
76
+
data : kv_table option;
77
77
mutable named_tables : (string * kv_table) list;
78
78
mutable all_tables : generic_table list;
79
79
mutable extra_master : raw_master_entry list;
···
228
228
ui_btree = Btree.Index.v pager;
229
229
})
230
230
constraints
231
-
232
-
(* Populate persistent indexes from existing table data (used on migration) *)
233
-
let populate_unique_indexes btree schema indexes =
234
-
let index_row ui values =
235
-
match encode_index_key ui values with
236
-
| None -> ()
237
-
| Some key -> Btree.Index.insert ui.ui_btree key
238
-
in
239
-
if indexes <> [] then
240
-
Btree.Table.iter btree (fun rowid payload ->
241
-
let values = Btree.Record.decode payload in
242
-
let values = fixup_values ~schema ~rowid values in
243
-
List.iter (fun ui -> index_row ui values) indexes)
244
231
245
232
(* Standard kv table schema *)
246
233
let kv_columns =
···
959
946
960
947
module Table = struct
961
948
type db = t
962
-
type t = { parent : db; name : string; kv : kv_table }
949
+
type t = { kv : kv_table }
963
950
964
951
let valid_name name =
965
952
String.length name > 0
···
978
965
let create parent ~name =
979
966
if not (valid_name name) then Fmt.invalid_arg "Invalid table name: %S" name;
980
967
match List.assoc_opt name parent.named_tables with
981
-
| Some kv -> { parent; name; kv }
968
+
| Some kv -> { kv }
982
969
| None ->
983
970
(* Check if a table with this name already exists (e.g. the default
984
971
"kv" table or a table created via create_table). If so, reuse it
···
1006
993
kv
1007
994
in
1008
995
parent.named_tables <- (name, kv) :: parent.named_tables;
1009
-
{ parent; name; kv }
996
+
{ kv }
1010
997
1011
998
(* Scan the B-tree for a key, returning (rowid, value) if found.
1012
999
This is the authoritative lookup — no stale cache. *)
-24
ocaml-sqlite/test/test_sqlite.ml
-24
ocaml-sqlite/test/test_sqlite.ml
···
1931
1931
write_db path [ Bytes.unsafe_to_string page1; Bytes.unsafe_to_string page2 ];
1932
1932
must_fail_or_succeed_safely sw path
1933
1933
1934
-
(* -- CVE-2023-7104 inspired: truncated/malformed WAL -- *)
1935
-
1936
-
let test_truncated_wal () =
1937
-
with_temp_hostile @@ fun sw path ->
1938
-
(* Create a valid empty DB first *)
1939
-
Eio.Switch.run @@ fun init_sw ->
1940
-
let db = Sqlite.open_ ~sw:init_sw ~create:true path in
1941
-
Sqlite.put db "key" "value";
1942
-
Sqlite.close db;
1943
-
(* Now write a truncated WAL file *)
1944
-
let wal_path = Eio.Path.(Eio.Path.native_exn path ^ "-wal") in
1945
-
let wal_path = Eio.Path.(Eio.Stdenv.cwd (Eio_main.run Fun.id) / wal_path) in
1946
-
ignore wal_path;
1947
-
(* Write garbage to where the WAL would be *)
1948
-
let wal_name = Eio.Path.native_exn path ^ "-wal" in
1949
-
let oc = open_out_bin wal_name in
1950
-
output_string oc "\x00\x01\x02";
1951
-
(* 3 bytes, way too short *)
1952
-
close_out oc;
1953
-
(* Reopen — must handle the corrupt WAL gracefully *)
1954
-
must_fail_or_succeed_safely sw path;
1955
-
(* Clean up *)
1956
-
try Sys.remove wal_name with Sys_error _ -> ()
1957
-
1958
1934
(* -- Root page beyond file -- *)
1959
1935
1960
1936
let test_root_page_oob () =
-1
ocaml-squashfs/c/dune
-1
ocaml-squashfs/c/dune
-1
ocaml-squashfs/fuzz/dune
-1
ocaml-squashfs/fuzz/dune
-5
ocaml-squashfs/lib/squashfs.ml
-5
ocaml-squashfs/lib/squashfs.ml
···
163
163
uid_idx : int;
164
164
gid_idx : int;
165
165
mtime : int;
166
-
inode_number : int;
167
166
inode_data : inode_data;
168
167
xattr_id : int; (* 0xFFFFFFFF = no xattrs *)
169
168
}
···
178
177
root_inode : inode;
179
178
inode_table_start : int64;
180
179
directory_table_start : int64;
181
-
fragment_table_start : int64;
182
180
xattr_table_start : int64;
183
181
}
184
182
···
881
879
uid_idx = hdr.ih_uid_idx;
882
880
gid_idx = hdr.ih_gid_idx;
883
881
mtime = hdr.ih_mtime;
884
-
inode_number = hdr.ih_inode_number;
885
882
inode_data;
886
883
xattr_id;
887
884
}
···
968
965
uid_idx = 0;
969
966
gid_idx = 0;
970
967
mtime = 0;
971
-
inode_number = 0;
972
968
inode_data =
973
969
Inode_dir
974
970
{
···
982
978
};
983
979
inode_table_start = raw.sb_inode_table_start;
984
980
directory_table_start = raw.sb_directory_table_start;
985
-
fragment_table_start = raw.sb_fragment_table_start;
986
981
xattr_table_start = raw.sb_xattr_table_start;
987
982
}
988
983
in
+3
-19
ocaml-squashfs/lib/squashfs_writer.ml
+3
-19
ocaml-squashfs/lib/squashfs_writer.ml
···
70
70
compression : compression;
71
71
block_size : int;
72
72
mtime : int;
73
-
mutable next_inode : int;
74
-
mutable uid_gid_table : (int * int) list;
75
73
}
76
74
77
75
let pp ppf t =
···
439
437
in
440
438
if not (is_power_of_2 block_size) then
441
439
invalid_arg "block_size must be a power of 2";
442
-
{
443
-
root = [];
444
-
compression;
445
-
block_size;
446
-
mtime;
447
-
next_inode = 1;
448
-
uid_gid_table = [ (0, 0) ];
449
-
}
440
+
{ root = []; compression; block_size; mtime }
450
441
451
442
(* Find or create path to entry *)
452
443
let rec ensure_dir t components current =
···
584
575
type inode_info = {
585
576
inode_number : int;
586
577
block_offset : int; (* Offset within metadata block *)
587
-
block_start : int; (* Start of metadata block relative to inode table *)
588
578
}
589
579
590
580
let encode_inode_header buf offset inode_type mode uid_idx gid_idx mtime
···
719
709
let inode_number = !current_inode in
720
710
incr current_inode;
721
711
let inode_offset = Buffer.length inode_table in
722
-
Hashtbl.add inode_positions path
723
-
{
724
-
inode_number;
725
-
block_offset = inode_offset;
726
-
block_start = !inode_block_start;
727
-
};
712
+
Hashtbl.add inode_positions path { inode_number; block_offset = inode_offset };
728
713
(match entry with
729
714
| Dir { mode; children } ->
730
715
write_dir_inode_buf t inode_table inode_number mode children parent_inode;
···
773
758
buf off)
774
759
in
775
760
Buffer.add_bytes inode_table buf;
776
-
Hashtbl.add inode_positions "/"
777
-
{ inode_number; block_offset = 0; block_start = 0 };
761
+
Hashtbl.add inode_positions "/" { inode_number; block_offset = 0 };
778
762
inode_number
779
763
780
764
(* Map an entry to its on-disk directory entry type integer *)
-1
ocaml-srp/fuzz/dune
-1
ocaml-srp/fuzz/dune
-1
ocaml-streaming-aead/fuzz/dune
-1
ocaml-streaming-aead/fuzz/dune
+4
-1
ocaml-streaming-aead/lib/streaming_aead.ml
+4
-1
ocaml-streaming-aead/lib/streaming_aead.ml
···
255
255
else if Bytes.length segment < nonce_size + tag_size then Error Truncated
256
256
else
257
257
let nonce = Bytes.sub_string segment 0 nonce_size in
258
+
let segment_prefix = String.sub nonce 0 nonce_prefix_size in
258
259
let nonce_counter = Int32.to_int (String.get_int32_be nonce 7) in
259
260
let is_final = String.get_uint8 nonce 11 = 0x01 in
260
261
261
-
if nonce_counter <> t.counter then
262
+
if not (String.equal segment_prefix t.nonce_prefix) then
263
+
Error Authentication_failed
264
+
else if nonce_counter <> t.counter then
262
265
Error
263
266
(Segment_out_of_order { expected = t.counter; got = nonce_counter })
264
267
else
+1
-1
ocaml-stripe/lib/dune
+1
-1
ocaml-stripe/lib/dune
+89
-84
ocaml-stripe/lib/stripe.ml
+89
-84
ocaml-stripe/lib/stripe.ml
···
27
27
exception Stripe_error of error
28
28
29
29
let error_jsont =
30
-
Json.Object.map (fun error_type message code ->
30
+
Json.Codec.Object.map (fun error_type message code ->
31
31
{ error_type; message; code; status = 0 })
32
-
|> Json.Object.mem "type" Json.string ~dec_absent:"" ~enc:(fun e ->
33
-
e.error_type)
34
-
|> Json.Object.mem "message" Json.string ~dec_absent:"" ~enc:(fun e ->
35
-
e.message)
36
-
|> Json.Object.mem "code" Json.string ~dec_absent:"" ~enc:(fun e -> e.code)
37
-
|> Json.Object.finish
32
+
|> Json.Codec.Object.mem "type" Json.Codec.string ~dec_absent:""
33
+
~enc:(fun e -> e.error_type)
34
+
|> Json.Codec.Object.mem "message" Json.Codec.string ~dec_absent:""
35
+
~enc:(fun e -> e.message)
36
+
|> Json.Codec.Object.mem "code" Json.Codec.string ~dec_absent:""
37
+
~enc:(fun e -> e.code)
38
+
|> Json.Codec.Object.finish
38
39
39
40
let error_wrapper_jsont =
40
-
Json.Object.map Fun.id
41
-
|> Json.Object.mem "error" error_jsont ~enc:Fun.id
42
-
|> Json.Object.finish
41
+
Json.Codec.Object.map Fun.id
42
+
|> Json.Codec.Object.mem "error" error_jsont ~enc:Fun.id
43
+
|> Json.Codec.Object.finish
43
44
44
45
(* {1 Common types} *)
45
46
···
47
48
48
49
type metadata = string Smap.t
49
50
50
-
let metadata_jsont = Json.Object.as_string_map Json.string
51
+
let metadata_jsont = Json.Codec.Object.as_string_map Json.Codec.string
51
52
52
53
(* {1 HTTP helpers} *)
53
54
···
58
59
let text = Requests.Response.text resp in
59
60
if status >= 400 then begin
60
61
let err =
61
-
match Json_bytesrw.decode_string error_wrapper_jsont text with
62
+
match Json.of_string error_wrapper_jsont text with
62
63
| Ok e -> { e with status }
63
64
| Error _ ->
64
65
{ error_type = "api_error"; message = text; code = ""; status }
···
76
77
let url = base_url ^ path in
77
78
Requests.get cfg.session url ~auth:(auth cfg) ~params |> check_response
78
79
79
-
let delete cfg path =
80
-
let url = base_url ^ path in
81
-
Requests.delete cfg.session url ~auth:(auth cfg) |> check_response
82
-
83
80
let decode jsont text =
84
-
match Json_bytesrw.decode_string jsont text with
81
+
match Json.of_string jsont text with
85
82
| Ok v -> v
86
-
| Error e -> Fmt.failwith "Stripe JSON decode: %s" e
83
+
| Error e -> Fmt.failwith "Stripe JSON decode: %s" (Loc.Error.to_string e)
87
84
88
85
let list_jsont item_jsont =
89
-
Json.Object.map (fun data has_more -> (data, has_more))
90
-
|> Json.Object.mem "data" (Json.list item_jsont) ~enc:(fun (d, _) -> d)
91
-
|> Json.Object.mem "has_more" Json.bool ~enc:(fun (_, h) -> h)
92
-
|> Json.Object.finish
86
+
Json.Codec.Object.map (fun data has_more -> (data, has_more))
87
+
|> Json.Codec.Object.mem "data" (Json.Codec.list item_jsont)
88
+
~enc:(fun (d, _) -> d)
89
+
|> Json.Codec.Object.mem "has_more" Json.Codec.bool ~enc:(fun (_, h) -> h)
90
+
|> Json.Codec.Object.finish
93
91
94
92
(* {1 Customers} *)
95
93
···
105
103
let pp ppf c = Fmt.pf ppf "customer(%s, %s, %s)" c.id c.email c.name
106
104
107
105
let jsont =
108
-
Json.Object.map (fun id email name metadata created ->
106
+
Json.Codec.Object.map (fun id email name metadata created ->
109
107
{ id; email; name; metadata; created })
110
-
|> Json.Object.mem "id" Json.string ~enc:(fun c -> c.id)
111
-
|> Json.Object.mem "email" Json.string ~dec_absent:"" ~enc:(fun c ->
112
-
c.email)
113
-
|> Json.Object.mem "name" Json.string ~dec_absent:"" ~enc:(fun c ->
114
-
c.name)
115
-
|> Json.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
108
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun c -> c.id)
109
+
|> Json.Codec.Object.mem "email" Json.Codec.string ~dec_absent:""
110
+
~enc:(fun c -> c.email)
111
+
|> Json.Codec.Object.mem "name" Json.Codec.string ~dec_absent:""
112
+
~enc:(fun c -> c.name)
113
+
|> Json.Codec.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
116
114
~enc:(fun c -> c.metadata)
117
-
|> Json.Object.mem "created" Json.int ~dec_absent:0 ~enc:(fun c ->
118
-
c.created)
119
-
|> Json.Object.finish
115
+
|> Json.Codec.Object.mem "created" Json.Codec.int ~dec_absent:0
116
+
~enc:(fun c -> c.created)
117
+
|> Json.Codec.Object.finish
120
118
121
119
let create cfg ~email ?name ?metadata () =
122
120
let body =
···
151
149
let pp ppf p = Fmt.pf ppf "product(%s, %s)" p.id p.name
152
150
153
151
let jsont =
154
-
Json.Object.map (fun id name active metadata ->
152
+
Json.Codec.Object.map (fun id name active metadata ->
155
153
{ id; name; active; metadata })
156
-
|> Json.Object.mem "id" Json.string ~enc:(fun p -> p.id)
157
-
|> Json.Object.mem "name" Json.string ~enc:(fun p -> p.name)
158
-
|> Json.Object.mem "active" Json.bool ~dec_absent:true ~enc:(fun p ->
159
-
p.active)
160
-
|> Json.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
154
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun p -> p.id)
155
+
|> Json.Codec.Object.mem "name" Json.Codec.string ~enc:(fun p -> p.name)
156
+
|> Json.Codec.Object.mem "active" Json.Codec.bool ~dec_absent:true
157
+
~enc:(fun p -> p.active)
158
+
|> Json.Codec.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
161
159
~enc:(fun p -> p.metadata)
162
-
|> Json.Object.finish
160
+
|> Json.Codec.Object.finish
163
161
164
162
let create cfg ~name ?metadata () =
165
163
let body =
···
181
179
type recurring = { interval : string; interval_count : int }
182
180
183
181
let recurring_jsont =
184
-
Json.Object.map (fun interval interval_count ->
182
+
Json.Codec.Object.map (fun interval interval_count ->
185
183
{ interval; interval_count })
186
-
|> Json.Object.mem "interval" Json.string ~enc:(fun r -> r.interval)
187
-
|> Json.Object.mem "interval_count" Json.int ~dec_absent:1 ~enc:(fun r ->
188
-
r.interval_count)
189
-
|> Json.Object.finish
184
+
|> Json.Codec.Object.mem "interval" Json.Codec.string ~enc:(fun r ->
185
+
r.interval)
186
+
|> Json.Codec.Object.mem "interval_count" Json.Codec.int ~dec_absent:1
187
+
~enc:(fun r -> r.interval_count)
188
+
|> Json.Codec.Object.finish
190
189
191
190
type t = {
192
191
id : string;
···
200
199
let pp ppf p = Fmt.pf ppf "price(%s, %d %s)" p.id p.unit_amount p.currency
201
200
202
201
let jsont =
203
-
Json.Object.map (fun id product unit_amount currency recurring active ->
202
+
Json.Codec.Object.map
203
+
(fun id product unit_amount currency recurring active ->
204
204
{ id; product; unit_amount; currency; recurring; active })
205
-
|> Json.Object.mem "id" Json.string ~enc:(fun p -> p.id)
206
-
|> Json.Object.mem "product" Json.string ~enc:(fun p -> p.product)
207
-
|> Json.Object.mem "unit_amount" Json.int ~dec_absent:0 ~enc:(fun p ->
208
-
p.unit_amount)
209
-
|> Json.Object.mem "currency" Json.string ~enc:(fun p -> p.currency)
210
-
|> Json.Object.mem "recurring" (Json.option recurring_jsont)
205
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun p -> p.id)
206
+
|> Json.Codec.Object.mem "product" Json.Codec.string ~enc:(fun p ->
207
+
p.product)
208
+
|> Json.Codec.Object.mem "unit_amount" Json.Codec.int ~dec_absent:0
209
+
~enc:(fun p -> p.unit_amount)
210
+
|> Json.Codec.Object.mem "currency" Json.Codec.string ~enc:(fun p ->
211
+
p.currency)
212
+
|> Json.Codec.Object.mem "recurring" (Json.Codec.option recurring_jsont)
211
213
~dec_absent:None ~enc:(fun p -> p.recurring)
212
-
|> Json.Object.mem "active" Json.bool ~dec_absent:true ~enc:(fun p ->
213
-
p.active)
214
-
|> Json.Object.finish
214
+
|> Json.Codec.Object.mem "active" Json.Codec.bool ~dec_absent:true
215
+
~enc:(fun p -> p.active)
216
+
|> Json.Codec.Object.finish
215
217
216
218
let create cfg ~product ~unit_amount ~currency ?interval ?interval_count () =
217
219
let body =
···
249
251
let pp ppf s = Fmt.pf ppf "subscription(%s, %s, %s)" s.id s.customer s.status
250
252
251
253
let jsont =
252
-
Json.Object.map
254
+
Json.Codec.Object.map
253
255
(fun
254
256
id
255
257
customer
···
268
270
cancel_at_period_end;
269
271
metadata;
270
272
})
271
-
|> Json.Object.mem "id" Json.string ~enc:(fun s -> s.id)
272
-
|> Json.Object.mem "customer" Json.string ~enc:(fun s -> s.customer)
273
-
|> Json.Object.mem "status" Json.string ~enc:(fun s -> s.status)
274
-
|> Json.Object.mem "current_period_start" Json.int ~dec_absent:0
273
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun s -> s.id)
274
+
|> Json.Codec.Object.mem "customer" Json.Codec.string ~enc:(fun s ->
275
+
s.customer)
276
+
|> Json.Codec.Object.mem "status" Json.Codec.string ~enc:(fun s -> s.status)
277
+
|> Json.Codec.Object.mem "current_period_start" Json.Codec.int ~dec_absent:0
275
278
~enc:(fun s -> s.current_period_start)
276
-
|> Json.Object.mem "current_period_end" Json.int ~dec_absent:0
279
+
|> Json.Codec.Object.mem "current_period_end" Json.Codec.int ~dec_absent:0
277
280
~enc:(fun s -> s.current_period_end)
278
-
|> Json.Object.mem "cancel_at_period_end" Json.bool ~dec_absent:false
279
-
~enc:(fun s -> s.cancel_at_period_end)
280
-
|> Json.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
281
+
|> Json.Codec.Object.mem "cancel_at_period_end" Json.Codec.bool
282
+
~dec_absent:false ~enc:(fun s -> s.cancel_at_period_end)
283
+
|> Json.Codec.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
281
284
~enc:(fun s -> s.metadata)
282
-
|> Json.Object.finish
285
+
|> Json.Codec.Object.finish
283
286
284
287
let create cfg ~customer ~price ?metadata () =
285
288
let body =
···
313
316
let pp ppf c = Fmt.pf ppf "checkout(%s, %s)" c.id c.status
314
317
315
318
let jsont =
316
-
Json.Object.map (fun id url customer subscription status ->
319
+
Json.Codec.Object.map (fun id url customer subscription status ->
317
320
{ id; url; customer; subscription; status })
318
-
|> Json.Object.mem "id" Json.string ~enc:(fun c -> c.id)
319
-
|> Json.Object.mem "url" Json.string ~dec_absent:"" ~enc:(fun c -> c.url)
320
-
|> Json.Object.mem "customer" Json.string ~dec_absent:"" ~enc:(fun c ->
321
-
c.customer)
322
-
|> Json.Object.mem "subscription" Json.string ~dec_absent:""
321
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun c -> c.id)
322
+
|> Json.Codec.Object.mem "url" Json.Codec.string ~dec_absent:""
323
+
~enc:(fun c -> c.url)
324
+
|> Json.Codec.Object.mem "customer" Json.Codec.string ~dec_absent:""
325
+
~enc:(fun c -> c.customer)
326
+
|> Json.Codec.Object.mem "subscription" Json.Codec.string ~dec_absent:""
323
327
~enc:(fun c -> c.subscription)
324
-
|> Json.Object.mem "status" Json.string ~dec_absent:"" ~enc:(fun c ->
325
-
c.status)
326
-
|> Json.Object.finish
328
+
|> Json.Codec.Object.mem "status" Json.Codec.string ~dec_absent:""
329
+
~enc:(fun c -> c.status)
330
+
|> Json.Codec.Object.finish
327
331
328
332
let create cfg ?customer ?customer_email ~price ~success_url ~cancel_url () =
329
333
let body =
···
353
357
let pp ppf p = Fmt.pf ppf "portal(%s)" p.id
354
358
355
359
let jsont =
356
-
Json.Object.map (fun id url -> { id; url })
357
-
|> Json.Object.mem "id" Json.string ~enc:(fun p -> p.id)
358
-
|> Json.Object.mem "url" Json.string ~enc:(fun p -> p.url)
359
-
|> Json.Object.finish
360
+
Json.Codec.Object.map (fun id url -> { id; url })
361
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun p -> p.id)
362
+
|> Json.Codec.Object.mem "url" Json.Codec.string ~enc:(fun p -> p.url)
363
+
|> Json.Codec.Object.finish
360
364
361
365
let create cfg ~customer ~return_url =
362
366
let body = [ ("customer", customer); ("return_url", return_url) ] in
···
376
380
let pp_event ppf e = Fmt.pf ppf "event(%s, %s)" e.id e.event_type
377
381
378
382
let event_jsont =
379
-
Json.Object.map (fun id event_type created data ->
383
+
Json.Codec.Object.map (fun id event_type created data ->
380
384
{ id; event_type; created; data })
381
-
|> Json.Object.mem "id" Json.string ~enc:(fun e -> e.id)
382
-
|> Json.Object.mem "type" Json.string ~enc:(fun e -> e.event_type)
383
-
|> Json.Object.mem "created" Json.int ~dec_absent:0 ~enc:(fun e ->
384
-
e.created)
385
-
|> Json.Object.mem "data" Json.json ~enc:(fun e -> e.data)
386
-
|> Json.Object.finish
385
+
|> Json.Codec.Object.mem "id" Json.Codec.string ~enc:(fun e -> e.id)
386
+
|> Json.Codec.Object.mem "type" Json.Codec.string ~enc:(fun e ->
387
+
e.event_type)
388
+
|> Json.Codec.Object.mem "created" Json.Codec.int ~dec_absent:0
389
+
~enc:(fun e -> e.created)
390
+
|> Json.Codec.Object.mem "data" Json.Codec.Value.t ~enc:(fun e -> e.data)
391
+
|> Json.Codec.Object.finish
387
392
388
393
(* Stripe webhook signature verification.
389
394
Header format: t=<timestamp>,v1=<sig1>,v1=<sig2>,...
+1
-1
ocaml-stripe/test/dune
+1
-1
ocaml-stripe/test/dune
+13
-14
ocaml-stripe/test/test_stripe.ml
+13
-14
ocaml-stripe/test/test_stripe.ml
···
39
39
Alcotest.(check string)
40
40
"event type" "customer.subscription.updated" event.event_type;
41
41
Alcotest.(check int) "created" 1735732800 event.created
42
-
| Error e -> Alcotest.failf "verification failed: %s" e
42
+
| Error e -> Alcotest.failf "verification failed: %s" (Loc.Error.to_string e)
43
43
44
44
(* Wrong secret should fail *)
45
45
let wrong_secret () =
···
114
114
~payload:sample_event_json ~signature:sig_header
115
115
with
116
116
| Ok event -> Alcotest.(check string) "event id" "evt_test_123" event.id
117
-
| Error e -> Alcotest.failf "should accept any valid v1: %s" e
117
+
| Error e ->
118
+
Alcotest.failf "should accept any valid v1: %s" (Loc.Error.to_string e)
118
119
119
120
(* {1 JSON codec tests} *)
120
121
···
122
123
{|{"id":"cus_test_123","email":"test@example.com","name":"Test User","metadata":{"plan":"pro"},"created":1735732800,"object":"customer"}|}
123
124
124
125
let customer_roundtrip () =
125
-
match Json_bytesrw.decode_string Stripe.Customer.jsont customer_json with
126
-
| Error e -> Alcotest.failf "decode: %s" e
126
+
match Json.of_string Stripe.Customer.jsont customer_json with
127
+
| Error e -> Alcotest.failf "decode: %s" (Loc.Error.to_string e)
127
128
| Ok c ->
128
129
Alcotest.(check string) "id" "cus_test_123" c.id;
129
130
Alcotest.(check string) "email" "test@example.com" c.email;
···
137
138
{|{"id":"sub_test_456","customer":"cus_test_123","status":"active","current_period_start":1735732800,"current_period_end":1738411200,"cancel_at_period_end":false,"metadata":{},"object":"subscription"}|}
138
139
139
140
let subscription_roundtrip () =
140
-
match
141
-
Json_bytesrw.decode_string Stripe.Subscription.jsont subscription_json
142
-
with
143
-
| Error e -> Alcotest.failf "decode: %s" e
141
+
match Json.of_string Stripe.Subscription.jsont subscription_json with
142
+
| Error e -> Alcotest.failf "decode: %s" (Loc.Error.to_string e)
144
143
| Ok s ->
145
144
Alcotest.(check string) "id" "sub_test_456" s.id;
146
145
Alcotest.(check string) "customer" "cus_test_123" s.customer;
···
151
150
{|{"id":"price_test_789","product":"prod_test_abc","unit_amount":500000,"currency":"usd","recurring":{"interval":"year","interval_count":1},"active":true,"object":"price"}|}
152
151
153
152
let price_roundtrip () =
154
-
match Json_bytesrw.decode_string Stripe.Price.jsont price_json with
155
-
| Error e -> Alcotest.failf "decode: %s" e
153
+
match Json.of_string Stripe.Price.jsont price_json with
154
+
| Error e -> Alcotest.failf "decode: %s" (Loc.Error.to_string e)
156
155
| Ok p -> (
157
156
Alcotest.(check string) "id" "price_test_789" p.id;
158
157
Alcotest.(check string) "product" "prod_test_abc" p.product;
···
168
167
{|{"id":"prod_test_abc","name":"SSA Pro","active":true,"metadata":{"tier":"pro"},"object":"product"}|}
169
168
170
169
let product_roundtrip () =
171
-
match Json_bytesrw.decode_string Stripe.Product.jsont product_json with
172
-
| Error e -> Alcotest.failf "decode: %s" e
170
+
match Json.of_string Stripe.Product.jsont product_json with
171
+
| Error e -> Alcotest.failf "decode: %s" (Loc.Error.to_string e)
173
172
| Ok p ->
174
173
Alcotest.(check string) "id" "prod_test_abc" p.id;
175
174
Alcotest.(check string) "name" "SSA Pro" p.name;
···
179
178
{|{"id":"cs_test_xyz","url":"https://checkout.stripe.com/pay/cs_test_xyz","customer":"cus_test_123","subscription":"sub_test_456","status":"open","object":"checkout.session"}|}
180
179
181
180
let checkout_roundtrip () =
182
-
match Json_bytesrw.decode_string Stripe.Checkout.jsont checkout_json with
183
-
| Error e -> Alcotest.failf "decode: %s" e
181
+
match Json.of_string Stripe.Checkout.jsont checkout_json with
182
+
| Error e -> Alcotest.failf "decode: %s" (Loc.Error.to_string e)
184
183
| Ok c ->
185
184
Alcotest.(check string) "id" "cs_test_xyz" c.id;
186
185
Alcotest.(check bool) "has url" true (String.length c.url > 0);
-1
ocaml-tar/fuzz/dune
-1
ocaml-tar/fuzz/dune
-1
ocaml-tc/c/dune
-1
ocaml-tc/c/dune
-1
ocaml-tc/fuzz/dune
-1
ocaml-tc/fuzz/dune
-1
ocaml-tcf/test/dune
-1
ocaml-tcf/test/dune
-2
ocaml-tcf/test/test_tcf.ml
-2
ocaml-tcf/test/test_tcf.ml
-1
ocaml-tcpcl/c/dune
-1
ocaml-tcpcl/c/dune
-1
ocaml-tcpcl/fuzz/dune
-1
ocaml-tcpcl/fuzz/dune
-1
ocaml-tls/eio/tests/dune
-1
ocaml-tls/eio/tests/dune
-1
ocaml-tls/eio/tests/fuzz/dune
-1
ocaml-tls/eio/tests/fuzz/dune
-1
ocaml-tls/fuzz/dune
-1
ocaml-tls/fuzz/dune
-1
ocaml-tls/test/eio/dune
-1
ocaml-tls/test/eio/dune
-1
ocaml-tls/test/helpers/dune
-1
ocaml-tls/test/helpers/dune
-1
ocaml-tm/bench/dune
-1
ocaml-tm/bench/dune
-1
ocaml-tm/c/dune
-1
ocaml-tm/c/dune
-1
ocaml-tm/fuzz/dune
-1
ocaml-tm/fuzz/dune
+1
-1
ocaml-toml/README.md
+1
-1
ocaml-toml/README.md
···
41
41
port = 8080
42
42
|} with
43
43
| Ok config -> Printf.printf "Host: %s\n" config.host
44
-
| Error e -> prerr_endline (Toml.Value.Error.to_string e)
44
+
| Error e -> prerr_endline (Toml.Error.to_string e)
45
45
```
46
46
47
47
For streaming decode from a bytesrw reader, use `Toml.of_reader`.
+2
-3
ocaml-toml/bin/run_tests.ml
+2
-3
ocaml-toml/bin/run_tests.ml
···
278
278
let run_valid_test toml_file json_file =
279
279
let toml_content = In_channel.with_open_bin toml_file In_channel.input_all in
280
280
match Toml.Parser.of_string toml_content with
281
-
| Error e -> `Fail (Fmt.str "Decode error: %s" (Toml.Value.Error.to_string e))
281
+
| Error e -> `Fail (Fmt.str "Decode error: %s" (Toml.Error.to_string e))
282
282
| Ok toml ->
283
283
let actual_json = Toml.Parser.Tagged_json.encode toml in
284
284
let expected_json =
···
309
309
| Error e ->
310
310
`Fail
311
311
(Fmt.str "Round-trip decode error: %s\nTOML was:\n%s"
312
-
(Toml.Value.Error.to_string e)
313
-
toml_output)
312
+
(Toml.Error.to_string e) toml_output)
314
313
| Ok decoded_toml ->
315
314
(* Compare the decoded result with original JSON *)
316
315
let actual_json = Toml.Parser.Tagged_json.encode decoded_toml in
+1
-1
ocaml-toml/bin/toml_test_decoder.ml
+1
-1
ocaml-toml/bin/toml_test_decoder.ml
+3
-3
ocaml-toml/lib/eio/toml_eio.ml
+3
-3
ocaml-toml/lib/eio/toml_eio.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
module Error = Toml.Value.Error
6
+
module Error = Toml.Error
7
7
8
8
type Eio.Exn.err += E of Error.t
9
9
···
16
16
true
17
17
| _ -> false)
18
18
19
-
let wrap_error f = try f () with Error.Error e -> raise (err e)
19
+
let wrap_error f = try f () with Loc.Error e -> raise (err e)
20
20
21
21
let parse ?file input =
22
22
try Toml.Parser.parse input
23
-
with Error.Error e ->
23
+
with Loc.Error e ->
24
24
let bt = Printexc.get_raw_backtrace () in
25
25
let eio_exn = err e in
26
26
let eio_exn =
+3
-4
ocaml-toml/lib/eio/toml_eio.mli
+3
-4
ocaml-toml/lib/eio/toml_eio.mli
···
40
40
41
41
(** {1 Eio Exception Integration} *)
42
42
43
-
type Eio.Exn.err += E of Toml.Value.Error.t (** TOML errors as Eio errors. *)
43
+
type Eio.Exn.err += E of Toml.Error.t (** TOML errors as Eio errors. *)
44
44
45
-
val err : Toml.Value.Error.t -> exn
45
+
val err : Toml.Error.t -> exn
46
46
(** [err e] creates an [Eio.Io] exception from TOML error [e]. *)
47
47
48
48
val wrap_error : (unit -> 'a) -> 'a
49
-
(** [wrap_error f] runs [f] and converts [Toml.Value.Error.Error] to [Eio.Io].
50
-
*)
49
+
(** [wrap_error f] runs [f] and converts [Loc.Error] to [Eio.Io]. *)
51
50
52
51
(** {1 Raw TOML Parsing} *)
53
52
+42
-54
ocaml-toml/lib/error.ml
+42
-54
ocaml-toml/lib/error.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** TOML parsing and encoding error types *)
7
-
8
-
type location = { line : int; column : int; file : string option }
9
-
(** Location in the input *)
6
+
(* TOML error helpers. Extends [Loc.Error] with typed TOML error kinds and
7
+
raising helpers used by the lexer, parser and encoder. *)
10
8
11
-
let pp_location fmt loc =
12
-
match loc.file with
13
-
| Some f -> Fmt.pf fmt "%s:%d:%d" f loc.line loc.column
14
-
| None -> Fmt.pf fmt "line %d, column %d" loc.line loc.column
9
+
(* Typed error payloads *)
15
10
16
-
(** Lexer errors - low-level tokenization issues *)
17
11
type lexer_error =
18
12
| Invalid_utf8
19
13
| Incomplete_utf8
20
14
| Invalid_escape of char
21
-
| Incomplete_escape of string (** e.g., "\\x", "\\u", "\\U" *)
15
+
| Incomplete_escape of string
22
16
| Invalid_unicode_escape of string
23
17
| Invalid_unicode_codepoint of int
24
18
| Surrogate_codepoint of int
···
50
44
| Unexpected_character c -> Fmt.pf fmt "unexpected character '%c'" c
51
45
| Unexpected_eof -> Fmt.pf fmt "unexpected end of input"
52
46
53
-
(** Number parsing errors *)
54
47
type number_error =
55
48
| Leading_zero
56
49
| Leading_underscore
···
83
76
| Invalid_octal_digit -> Fmt.pf fmt "invalid octal digit"
84
77
| Invalid_binary_digit -> Fmt.pf fmt "invalid binary digit"
85
78
86
-
(** DateTime parsing errors *)
87
79
type datetime_error =
88
80
| Invalid_month of int
89
-
| Invalid_day of int * int (** day, month *)
81
+
| Invalid_day of int * int
90
82
| Invalid_hour of int
91
83
| Invalid_minute of int
92
84
| Invalid_second of int
93
85
| Invalid_timezone_offset_hour of int
94
86
| Invalid_timezone_offset_minute of int
95
-
| Invalid_format of string (** expected format description *)
87
+
| Invalid_format of string
96
88
97
89
let pp_datetime_error fmt = function
98
90
| Invalid_month m -> Fmt.pf fmt "invalid month: %d" m
···
106
98
Fmt.pf fmt "invalid timezone offset minute: %d" m
107
99
| Invalid_format desc -> Fmt.pf fmt "invalid %s format" desc
108
100
109
-
(** Semantic/table structure errors *)
110
101
type semantic_error =
111
102
| Duplicate_key of string
112
103
| Table_already_defined of string
···
150
141
| Empty_key -> Fmt.pf fmt "empty key"
151
142
| Multiline_key -> Fmt.pf fmt "multiline strings are not allowed as keys"
152
143
153
-
(** Syntax errors *)
154
144
type syntax_error =
155
145
| Expected of string
156
146
| Invalid_table_header
···
166
156
| Unexpected_token s -> Fmt.pf fmt "unexpected token: %s" s
167
157
| Unexpected_bare_key k -> Fmt.pf fmt "unexpected bare key '%s' as value" k
168
158
169
-
(** Encoding errors *)
170
159
type encode_error = Cannot_encode_inline_table | Not_a_table
171
160
172
161
let pp_encode_error fmt = function
···
174
163
Fmt.pf fmt "cannot encode table inline without inline flag"
175
164
| Not_a_table -> Fmt.pf fmt "top-level TOML must be a table"
176
165
177
-
(** All error kinds *)
178
-
type kind =
166
+
(* Error kinds: extend the shared extensible variant. *)
167
+
168
+
type kind = Loc.Error.kind = ..
169
+
170
+
type Loc.Error.kind +=
179
171
| Lexer of lexer_error
180
172
| Number of number_error
181
173
| Datetime of datetime_error
···
183
175
| Syntax of syntax_error
184
176
| Encode of encode_error
185
177
186
-
let pp_kind fmt = function
187
-
| Lexer e -> pp_lexer_error fmt e
188
-
| Number e -> pp_number_error fmt e
189
-
| Datetime e -> pp_datetime_error fmt e
190
-
| Semantic e -> pp_semantic_error fmt e
191
-
| Syntax e -> pp_syntax_error fmt e
192
-
| Encode e -> pp_encode_error fmt e
193
-
194
-
type t = { kind : kind; location : location option }
195
-
(** Full error with location *)
196
-
197
-
let v ?location kind = { kind; location }
198
-
199
-
let pp fmt t =
200
-
match t.location with
201
-
| Some loc -> Fmt.pf fmt "%a: %a" pp_location loc pp_kind t.kind
202
-
| None -> pp_kind fmt t.kind
203
-
204
-
let to_string t = Fmt.str "%a" pp t
178
+
let () =
179
+
Loc.Error.register_kind_printer @@ function
180
+
| Lexer e -> Some (fun ppf -> pp_lexer_error ppf e)
181
+
| Number e -> Some (fun ppf -> pp_number_error ppf e)
182
+
| Datetime e -> Some (fun ppf -> pp_datetime_error ppf e)
183
+
| Semantic e -> Some (fun ppf -> pp_semantic_error ppf e)
184
+
| Syntax e -> Some (fun ppf -> pp_syntax_error ppf e)
185
+
| Encode e -> Some (fun ppf -> pp_encode_error ppf e)
186
+
| _ -> None
205
187
206
-
exception Error of t
207
-
(** Exception for TOML errors *)
188
+
(* Re-exports: thin aliases over Loc.Error. *)
208
189
209
-
let () =
210
-
Printexc.register_printer (function
211
-
| Error e -> Some (Fmt.str "Toml.Error: %a" pp e)
212
-
| _ -> None)
190
+
type t = Loc.Error.t = { ctx : Loc.Context.t; meta : Loc.Meta.t; kind : kind }
213
191
214
-
(** Raise a TOML error *)
215
-
let raise_error ?location kind = raise (Error { kind; location })
192
+
let kind_to_string = Loc.Error.kind_to_string
193
+
let v = Loc.Error.v
194
+
let msg = Loc.Error.msg
195
+
let raise = Loc.Error.raise
196
+
let fail = Loc.Error.fail
197
+
let failf = Loc.Error.failf
198
+
let expected = Loc.Error.expected
199
+
let push_array = Loc.Error.push_array
200
+
let push_object = Loc.Error.push_object
201
+
let adjust_context = Loc.Error.adjust_context
202
+
let pp = Loc.Error.pp
203
+
let to_string = Loc.Error.to_string
204
+
let puterr = Loc.Error.puterr
216
205
217
-
let raise_lexer ?location e = raise_error ?location (Lexer e)
218
-
let raise_number ?location e = raise_error ?location (Number e)
219
-
let raise_datetime ?location e = raise_error ?location (Datetime e)
220
-
let raise_semantic ?location e = raise_error ?location (Semantic e)
221
-
let raise_syntax ?location e = raise_error ?location (Syntax e)
222
-
let raise_encode ?location e = raise_error ?location (Encode e)
206
+
(* Raising helpers - one per payload category. *)
223
207
224
-
(** Create location from line and column *)
225
-
let loc ?file ~line ~column () = { line; column; file }
208
+
let raise_lexer ~meta e = raise ~ctx:Loc.Context.empty ~meta (Lexer e)
209
+
let raise_number ~meta e = raise ~ctx:Loc.Context.empty ~meta (Number e)
210
+
let raise_datetime ~meta e = raise ~ctx:Loc.Context.empty ~meta (Datetime e)
211
+
let raise_semantic ~meta e = raise ~ctx:Loc.Context.empty ~meta (Semantic e)
212
+
let raise_syntax ~meta e = raise ~ctx:Loc.Context.empty ~meta (Syntax e)
213
+
let raise_encode ~meta e = raise ~ctx:Loc.Context.empty ~meta (Encode e)
+72
-62
ocaml-toml/lib/error.mli
+72
-62
ocaml-toml/lib/error.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** TOML parsing and encoding error types.
7
-
8
-
This module defines structured error types for TOML parsing and encoding,
9
-
with location tracking and pretty-printing support. *)
10
-
11
-
(** {1 Location} *)
12
-
13
-
type location = { line : int; column : int; file : string option }
14
-
(** Location in the input *)
15
-
16
-
val pp_location : Format.formatter -> location -> unit
17
-
(** [pp_location fmt loc] pretty-prints a source location. *)
18
-
19
-
val loc : ?file:string -> line:int -> column:int -> unit -> location
20
-
(** [loc ?file ~line ~column ()] creates a source location value. *)
6
+
(** TOML error helpers. Extends {!Loc.Error} with typed TOML error kinds and
7
+
raising helpers used by the lexer, parser and encoder. *)
21
8
22
-
(** {1 Error Categories} *)
9
+
(** {1:payloads Typed error payloads} *)
23
10
24
-
(** Lexer errors - low-level tokenization issues *)
11
+
(** Lexer errors - low-level tokenization issues. *)
25
12
type lexer_error =
26
13
| Invalid_utf8
27
14
| Incomplete_utf8
28
15
| Invalid_escape of char
29
-
| Incomplete_escape of string
16
+
| Incomplete_escape of string (** e.g., "\\x", "\\u", "\\U" *)
30
17
| Invalid_unicode_escape of string
31
18
| Invalid_unicode_codepoint of int
32
19
| Surrogate_codepoint of int
···
40
27
| Unexpected_eof
41
28
42
29
val pp_lexer_error : Format.formatter -> lexer_error -> unit
43
-
(** [pp_lexer_error fmt e] pretty-prints a lexer error. *)
44
30
45
-
(** Number parsing errors *)
31
+
(** Number parsing errors. *)
46
32
type number_error =
47
33
| Leading_zero
48
34
| Leading_underscore
···
59
45
| Invalid_binary_digit
60
46
61
47
val pp_number_error : Format.formatter -> number_error -> unit
62
-
(** [pp_number_error fmt e] pretty-prints a number parsing error. *)
63
48
64
-
(** DateTime parsing errors *)
49
+
(** Datetime parsing errors. *)
65
50
type datetime_error =
66
51
| Invalid_month of int
67
-
| Invalid_day of int * int
52
+
| Invalid_day of int * int (** day, month *)
68
53
| Invalid_hour of int
69
54
| Invalid_minute of int
70
55
| Invalid_second of int
71
56
| Invalid_timezone_offset_hour of int
72
57
| Invalid_timezone_offset_minute of int
73
-
| Invalid_format of string
58
+
| Invalid_format of string (** expected format description *)
74
59
75
60
val pp_datetime_error : Format.formatter -> datetime_error -> unit
76
-
(** [pp_datetime_error fmt e] pretty-prints a datetime parsing error. *)
77
61
78
-
(** Semantic/table structure errors *)
62
+
(** Semantic / table structure errors. *)
79
63
type semantic_error =
80
64
| Duplicate_key of string
81
65
| Table_already_defined of string
···
93
77
| Multiline_key
94
78
95
79
val pp_semantic_error : Format.formatter -> semantic_error -> unit
96
-
(** [pp_semantic_error fmt e] pretty-prints a semantic error. *)
97
80
98
-
(** Syntax errors *)
81
+
(** Syntax errors. *)
99
82
type syntax_error =
100
83
| Expected of string
101
84
| Invalid_table_header
···
104
87
| Unexpected_bare_key of string
105
88
106
89
val pp_syntax_error : Format.formatter -> syntax_error -> unit
107
-
(** [pp_syntax_error fmt e] pretty-prints a syntax error. *)
108
90
109
-
(** Encoding errors *)
91
+
(** Encoding errors. *)
110
92
type encode_error = Cannot_encode_inline_table | Not_a_table
111
93
112
94
val pp_encode_error : Format.formatter -> encode_error -> unit
113
-
(** [pp_encode_error fmt e] pretty-prints an encoding error. *)
95
+
96
+
(** {1:kinds Error kinds}
114
97
115
-
(** {1 Combined Error Type} *)
98
+
TOML error kinds extend the shared extensible {!Loc.Error.kind}. Each
99
+
constructor carries one of the typed payloads above. *)
100
+
101
+
type kind = Loc.Error.kind = ..
102
+
(** Alias re-opens the extensible variant under this module's name. *)
116
103
117
-
(** All error kinds *)
118
-
type kind =
104
+
type Loc.Error.kind +=
119
105
| Lexer of lexer_error
120
106
| Number of number_error
121
107
| Datetime of datetime_error
···
123
109
| Syntax of syntax_error
124
110
| Encode of encode_error
125
111
126
-
val pp_kind : Format.formatter -> kind -> unit
127
-
(** [pp_kind fmt k] pretty-prints an error kind. *)
112
+
val kind_to_string : kind -> string
113
+
(** [kind_to_string k] renders [k] via the printers registered with
114
+
{!Loc.Error.register_kind_printer}. *)
128
115
129
-
type t = { kind : kind; location : location option }
130
-
(** Full error with location *)
116
+
(** {1:errors Errors}
131
117
132
-
val v : ?location:location -> kind -> t
133
-
(** [v ?location kind] creates an error value. *)
118
+
A full error is a {!Loc.Context.t} (path + sort labels), a {!Loc.Meta.t}
119
+
(source location + whitespace) and a {!kind}. *)
134
120
135
-
val pp : Format.formatter -> t -> unit
136
-
(** [pp fmt e] pretty-prints an error, including location if present. *)
121
+
type t = Loc.Error.t = { ctx : Loc.Context.t; meta : Loc.Meta.t; kind : kind }
137
122
138
-
val to_string : t -> string
139
-
(** [to_string e] returns a human-readable string representation of the error.
140
-
*)
123
+
val v : ctx:Loc.Context.t -> meta:Loc.Meta.t -> kind -> t
124
+
(** [v ~ctx ~meta k] is a fresh error. *)
141
125
142
-
(** {1 Exception} *)
126
+
val msg : ctx:Loc.Context.t -> meta:Loc.Meta.t -> string -> t
127
+
(** [msg ~ctx ~meta s] is an error with kind [Loc.Error.Msg s]. *)
143
128
144
-
exception Error of t
129
+
val raise : ctx:Loc.Context.t -> meta:Loc.Meta.t -> kind -> 'a
130
+
(** [raise ~ctx ~meta k] raises [Loc.Error.Error (v ~ctx ~meta k)]. *)
145
131
146
-
(** {1 Raising Errors} *)
132
+
val fail : Loc.Meta.t -> string -> 'a
133
+
(** [fail meta s] raises with empty context and string [s]. *)
147
134
148
-
val raise_error : ?location:location -> kind -> 'a
149
-
(** [raise_error ?location kind] raises an {!Error} exception. *)
135
+
val failf : Loc.Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a
136
+
(** [failf meta fmt] is {!fail} with a formatted message. *)
137
+
138
+
val expected : Loc.Meta.t -> string -> fnd:string -> 'a
139
+
(** [expected meta exp ~fnd] raises ["Expected exp but found fnd"]. *)
140
+
141
+
val push_array : string Loc.node -> int Loc.node -> t -> 'a
142
+
(** [push_array sort n e] re-raises [e] after pushing an array index onto its
143
+
context. *)
144
+
145
+
val push_object : string Loc.node -> string Loc.node -> t -> 'a
146
+
(** [push_object sort n e] re-raises [e] after pushing an object member onto its
147
+
context. *)
148
+
149
+
val adjust_context :
150
+
first_byte:Loc.byte_pos ->
151
+
first_line_num:Loc.line_num ->
152
+
first_line_byte:Loc.byte_pos ->
153
+
t ->
154
+
'a
155
+
(** [adjust_context] re-raises [e] with its innermost context's first position
156
+
updated. *)
150
157
151
-
val raise_lexer : ?location:location -> lexer_error -> 'a
152
-
(** [raise_lexer ?location e] raises a lexer error. *)
158
+
val pp : Format.formatter -> t -> unit
159
+
(** [pp] formats an error with its kind, source location and context. *)
153
160
154
-
val raise_number : ?location:location -> number_error -> 'a
155
-
(** [raise_number ?location e] raises a number parsing error. *)
161
+
val to_string : t -> string
162
+
(** [to_string e] is {!pp} as a string. *)
156
163
157
-
val raise_datetime : ?location:location -> datetime_error -> 'a
158
-
(** [raise_datetime ?location e] raises a datetime parsing error. *)
164
+
val puterr : Format.formatter -> unit -> unit
165
+
(** [puterr ppf ()] prints ["Error:"] (red/bold on ANSI formatters). *)
159
166
160
-
val raise_semantic : ?location:location -> semantic_error -> 'a
161
-
(** [raise_semantic ?location e] raises a semantic error. *)
167
+
(** {1:helpers Raising helpers}
162
168
163
-
val raise_syntax : ?location:location -> syntax_error -> 'a
164
-
(** [raise_syntax ?location e] raises a syntax error. *)
169
+
One helper per payload category. All take a {!Loc.Meta.t}: the parser builds
170
+
one from its current position. *)
165
171
166
-
val raise_encode : ?location:location -> encode_error -> 'a
167
-
(** [raise_encode ?location e] raises an encoding error. *)
172
+
val raise_lexer : meta:Loc.Meta.t -> lexer_error -> 'a
173
+
val raise_number : meta:Loc.Meta.t -> number_error -> 'a
174
+
val raise_datetime : meta:Loc.Meta.t -> datetime_error -> 'a
175
+
val raise_semantic : meta:Loc.Meta.t -> semantic_error -> 'a
176
+
val raise_syntax : meta:Loc.Meta.t -> syntax_error -> 'a
177
+
val raise_encode : meta:Loc.Meta.t -> encode_error -> 'a
+450
-360
ocaml-toml/lib/parser.ml
+450
-360
ocaml-toml/lib/parser.ml
···
7
7
8
8
(* Aliases for cleaner code *)
9
9
module V = Value
10
-
module Error = Value.Error
11
10
12
11
(* Lexer - streams bytes from a Bytes.Reader through a small lookahead window.
13
12
···
63
62
mutable eof : bool;
64
63
mutable line : int;
65
64
mutable col : int;
65
+
mutable byte : int; (* absolute byte offset of the next byte to consume *)
66
+
mutable line_byte : int;
67
+
(* absolute byte offset of the current line's start *)
66
68
file : string;
67
69
}
68
70
···
75
77
eof = false;
76
78
line = 1;
77
79
col = 1;
80
+
byte = 0;
81
+
line_byte = 0;
78
82
file;
79
83
}
80
84
···
167
171
if l.buf_len - l.buf_pos < n then None
168
172
else Some (Bytes.sub_string l.buf l.buf_pos n)
169
173
170
-
(* Advance over a byte we know is present in the window; updates line/col. *)
174
+
(* Advance over a byte we know is present in the window; updates
175
+
line/col and absolute byte tracking. *)
171
176
let advance l =
172
177
if l.buf_pos < l.buf_len then begin
173
178
let c = Bytes.unsafe_get l.buf l.buf_pos in
174
179
l.buf_pos <- l.buf_pos + 1;
180
+
l.byte <- l.byte + 1;
175
181
if c = '\n' then begin
176
182
l.line <- l.line + 1;
177
-
l.col <- 1
183
+
l.col <- 1;
184
+
l.line_byte <- l.byte
178
185
end
179
186
else l.col <- l.col + 1
180
187
end
···
183
190
if l.buf_pos < l.buf_len then begin
184
191
let c = Bytes.unsafe_get l.buf l.buf_pos in
185
192
l.buf_pos <- l.buf_pos + 1;
193
+
l.byte <- l.byte + 1;
186
194
if c = '\n' then begin
187
195
l.line <- l.line + 1;
188
-
l.col <- 1
196
+
l.col <- 1;
197
+
l.line_byte <- l.byte
189
198
end
190
199
else l.col <- l.col + 1
191
200
end
···
214
223
let[@inline] window_has l off = l.buf_pos + off < l.buf_len
215
224
let[@inline] current l = Bytes.unsafe_get l.buf l.buf_pos
216
225
217
-
(* Helper to create error location from lexer state *)
218
-
let lexer_loc l = Error.loc ~file:l.file ~line:l.line ~column:l.col ()
226
+
(* Build a [Loc.Meta.t] from the lexer's current position. The location
227
+
spans the single byte at [l.byte] (the next byte to consume); callers
228
+
that know a token's extent can widen it with [Loc.span]. *)
229
+
let lexer_meta l =
230
+
let textloc =
231
+
Loc.make ~file:l.file ~first_byte:l.byte ~last_byte:l.byte
232
+
~first_line_num:l.line ~first_line_byte:l.line_byte ~last_line_num:l.line
233
+
~last_line_byte:l.line_byte
234
+
in
235
+
Loc.Meta.make textloc
219
236
220
237
(* Get expected byte length of UTF-8 char from first byte *)
221
238
let utf8_first_byte_len c =
···
231
248
length of the encoded codepoint. Ensures enough bytes are in the
232
249
window for the full sequence. *)
233
250
let validate_utf8_at_pos_bytes l =
234
-
if is_eof l then Error.raise_lexer ~location:(lexer_loc l) Unexpected_eof;
251
+
if is_eof l then Error.raise_lexer ~meta:(lexer_meta l) Unexpected_eof;
235
252
let byte_len = utf8_first_byte_len (Bytes.unsafe_get l.buf l.buf_pos) in
236
-
if byte_len = 0 then Error.raise_lexer ~location:(lexer_loc l) Invalid_utf8;
253
+
if byte_len = 0 then Error.raise_lexer ~meta:(lexer_meta l) Invalid_utf8;
237
254
ensure_n l byte_len;
238
255
if l.buf_len - l.buf_pos < byte_len then
239
-
Error.raise_lexer ~location:(lexer_loc l) Incomplete_utf8;
256
+
Error.raise_lexer ~meta:(lexer_meta l) Incomplete_utf8;
240
257
(* Validate using uutf - it checks overlong encodings, surrogates, etc. *)
241
258
let sub = Bytes.sub_string l.buf l.buf_pos byte_len in
242
259
let valid = ref false in
243
260
Uutf.String.fold_utf_8
244
261
(fun () _ -> function `Uchar _ -> valid := true | `Malformed _ -> ())
245
262
() sub;
246
-
if not !valid then Error.raise_lexer ~location:(lexer_loc l) Invalid_utf8;
263
+
if not !valid then Error.raise_lexer ~meta:(lexer_meta l) Invalid_utf8;
247
264
byte_len
248
265
249
266
(* UTF-8 validation - validates and advances over a single UTF-8 character *)
···
275
292
begin if peek2 l = Some '\n' then
276
293
(* This is CRLF - stop the loop, let the main lexer handle it *)
277
294
continue := false
278
-
else Error.raise_lexer ~location:(lexer_loc l) Bare_carriage_return
295
+
else Error.raise_lexer ~meta:(lexer_meta l) Bare_carriage_return
279
296
end
280
297
else if code >= 0x80 then begin
281
298
(* Multi-byte UTF-8 character - validate it *)
···
284
301
else begin
285
302
(* ASCII control characters other than tab are not allowed in comments *)
286
303
if code < 0x09 || (code > 0x09 && code < 0x20) || code = 0x7F then
287
-
Error.raise_lexer ~location:(lexer_loc l) (Control_character code);
304
+
Error.raise_lexer ~meta:(lexer_meta l) (Control_character code);
288
305
advance l
289
306
end
290
307
done
···
318
335
if c >= '0' && c <= '9' then Char.code c - Char.code '0'
319
336
else if c >= 'a' && c <= 'f' then Char.code c - Char.code 'a' + 10
320
337
else if c >= 'A' && c <= 'F' then Char.code c - Char.code 'A' + 10
321
-
else Error.raise_number Invalid_hex_digit
338
+
else Error.raise_number ~meta:Loc.Meta.none Invalid_hex_digit
339
+
340
+
(* Convert Unicode codepoint to UTF-8 using uutf.
322
341
323
-
(* Convert Unicode codepoint to UTF-8 using uutf *)
342
+
This helper is only called from the Tagged_json decoder, which is a
343
+
JSON helper for the toml-test harness and not part of the main TOML
344
+
parse flow. Invalid codepoints here indicate malformed test input,
345
+
so we raise the regular Failure; the Tagged_json layer catches and
346
+
reports it as a string error. *)
324
347
let codepoint_to_utf8 codepoint =
325
348
if codepoint < 0 || codepoint > 0x10FFFF then
326
349
Fmt.failwith "Invalid Unicode codepoint: U+%X" codepoint;
···
333
356
(* Parse Unicode escape with error location from lexer *)
334
357
let unicode_to_utf8 l codepoint =
335
358
if codepoint < 0 || codepoint > 0x10FFFF then
336
-
Error.raise_lexer ~location:(lexer_loc l)
337
-
(Invalid_unicode_codepoint codepoint);
359
+
Error.raise_lexer ~meta:(lexer_meta l) (Invalid_unicode_codepoint codepoint);
338
360
if codepoint >= 0xD800 && codepoint <= 0xDFFF then
339
-
Error.raise_lexer ~location:(lexer_loc l) (Surrogate_codepoint codepoint);
361
+
Error.raise_lexer ~meta:(lexer_meta l) (Surrogate_codepoint codepoint);
340
362
let buf = Buffer.create 4 in
341
363
Uutf.Buffer.add_utf_8 buf (Uchar.of_int codepoint);
342
364
Buffer.contents buf
···
344
366
let parse_escape l =
345
367
advance l;
346
368
(* skip backslash *)
347
-
if is_eof l then Error.raise_lexer ~location:(lexer_loc l) Unexpected_eof;
369
+
if is_eof l then Error.raise_lexer ~meta:(lexer_meta l) Unexpected_eof;
348
370
let c = current l in
349
371
advance l;
350
372
match c with
···
360
382
(* \xHH - 2 hex digits *)
361
383
ensure_n l 2;
362
384
if l.buf_len - l.buf_pos < 2 then
363
-
Error.raise_lexer ~location:(lexer_loc l) (Incomplete_escape "\\x");
385
+
Error.raise_lexer ~meta:(lexer_meta l) (Incomplete_escape "\\x");
364
386
let c1 = Bytes.unsafe_get l.buf l.buf_pos in
365
387
let c2 = Bytes.unsafe_get l.buf (l.buf_pos + 1) in
366
388
if not (is_hex_digit c1 && is_hex_digit c2) then
367
-
Error.raise_lexer ~location:(lexer_loc l) (Invalid_unicode_escape "\\x");
389
+
Error.raise_lexer ~meta:(lexer_meta l) (Invalid_unicode_escape "\\x");
368
390
let cp = (hex_value c1 * 16) + hex_value c2 in
369
391
advance l;
370
392
advance l;
···
373
395
(* \uHHHH - 4 hex digits *)
374
396
ensure_n l 4;
375
397
if l.buf_len - l.buf_pos < 4 then
376
-
Error.raise_lexer ~location:(lexer_loc l) (Incomplete_escape "\\u");
398
+
Error.raise_lexer ~meta:(lexer_meta l) (Incomplete_escape "\\u");
377
399
let s = Bytes.sub_string l.buf l.buf_pos 4 in
378
400
for i = 0 to 3 do
379
401
if not (is_hex_digit s.[i]) then
380
-
Error.raise_lexer ~location:(lexer_loc l)
381
-
(Invalid_unicode_escape "\\u")
402
+
Error.raise_lexer ~meta:(lexer_meta l) (Invalid_unicode_escape "\\u")
382
403
done;
383
404
let cp = int_of_string ("0x" ^ s) in
384
405
advance_n l 4;
···
387
408
(* \UHHHHHHHH - 8 hex digits *)
388
409
ensure_n l 8;
389
410
if l.buf_len - l.buf_pos < 8 then
390
-
Error.raise_lexer ~location:(lexer_loc l) (Incomplete_escape "\\U");
411
+
Error.raise_lexer ~meta:(lexer_meta l) (Incomplete_escape "\\U");
391
412
let s = Bytes.sub_string l.buf l.buf_pos 8 in
392
413
for i = 0 to 7 do
393
414
if not (is_hex_digit s.[i]) then
394
-
Error.raise_lexer ~location:(lexer_loc l)
395
-
(Invalid_unicode_escape "\\U")
415
+
Error.raise_lexer ~meta:(lexer_meta l) (Invalid_unicode_escape "\\U")
396
416
done;
397
417
let cp = int_of_string ("0x" ^ s) in
398
418
advance_n l 8;
399
419
unicode_to_utf8 l cp
400
-
| _ -> Error.raise_lexer ~location:(lexer_loc l) (Invalid_escape c)
420
+
| _ -> Error.raise_lexer ~meta:(lexer_meta l) (Invalid_escape c)
401
421
402
422
let validate_string_char l c is_multiline =
403
423
let code = Char.code c in
404
424
(* Control characters other than tab (and LF/CR for multiline) are not allowed *)
405
425
if code < 0x09 then
406
-
Error.raise_lexer ~location:(lexer_loc l) (Control_character code);
426
+
Error.raise_lexer ~meta:(lexer_meta l) (Control_character code);
407
427
if
408
428
code > 0x09 && code < 0x20
409
429
&& not (is_multiline && (code = 0x0A || code = 0x0D))
410
-
then Error.raise_lexer ~location:(lexer_loc l) (Control_character code);
430
+
then Error.raise_lexer ~meta:(lexer_meta l) (Control_character code);
411
431
if code = 0x7F then
412
-
Error.raise_lexer ~location:(lexer_loc l) (Control_character code)
432
+
Error.raise_lexer ~meta:(lexer_meta l) (Control_character code)
413
433
414
434
(* Validate UTF-8 in string context and add bytes to buffer *)
415
435
let utf8_add_validated l buf = utf8_add_to_buffer l buf
416
436
417
-
let skip_opening_newline l errmsg =
437
+
let skip_opening_newline l =
418
438
match peek l with
419
439
| Some '\n' -> advance l
420
440
| Some '\r' ->
421
441
advance l;
422
-
if peek l = Some '\n' then advance l else failwith errmsg
442
+
if peek l = Some '\n' then advance l
443
+
else Error.raise_lexer ~meta:(lexer_meta l) Bare_carriage_return
423
444
| _ -> ()
424
445
425
446
let skip_all_ws_newlines l =
···
452
473
Buffer.add_char buf quote_char
453
474
done;
454
475
advance_n l !quote_count;
455
-
if !quote_count > 5 then failwith "Too many quotes in multiline string"
476
+
if !quote_count > 5 then
477
+
Error.raise_lexer ~meta:(lexer_meta l) Too_many_quotes
456
478
end
457
479
else begin
458
480
for _ = 1 to !quote_count do
···
508
530
end
509
531
510
532
let rec parse_multiline_basic_string l buf () =
511
-
if is_eof l then failwith "Unterminated string";
533
+
if is_eof l then Error.raise_lexer ~meta:(lexer_meta l) Unterminated_string;
512
534
let c = current l in
513
535
if c = '"' then
514
536
handle_multiline_quotes l buf '"' (parse_multiline_basic_string l buf)
···
520
542
if peek l = Some '\n' then (
521
543
Buffer.add_char buf '\n';
522
544
advance l)
523
-
else failwith "Bare carriage return not allowed in string"
545
+
else Error.raise_lexer ~meta:(lexer_meta l) Bare_carriage_return
524
546
end
525
547
else if Char.code c >= 0x80 then utf8_add_validated l buf
526
548
else begin
···
532
554
end
533
555
534
556
let rec parse_single_basic_string l buf () =
535
-
if is_eof l then failwith "Unterminated string";
557
+
if is_eof l then Error.raise_lexer ~meta:(lexer_meta l) Unterminated_string;
536
558
let c = current l in
537
559
if c = '"' then advance l
538
560
else if c = '\\' then (
539
561
Buffer.add_string buf (parse_escape l);
540
562
parse_single_basic_string l buf ())
541
563
else if c = '\n' || c = '\r' then
542
-
failwith "Newline not allowed in basic string"
564
+
Error.raise_lexer ~meta:(lexer_meta l) Newline_in_string
543
565
else begin
544
566
if Char.code c >= 0x80 then utf8_add_validated l buf
545
567
else begin
···
558
580
| Some "\"\"" ->
559
581
advance l;
560
582
advance l;
561
-
skip_opening_newline l "Bare carriage return not allowed in string";
583
+
skip_opening_newline l;
562
584
true
563
585
| _ -> false
564
586
in
···
576
598
else code < 0x09 || (code > 0x09 && code < 0x20) || code = 0x7F
577
599
in
578
600
if is_ctrl && code <> 0x0A && code <> 0x0D then
579
-
failwith
580
-
(Fmt.str
581
-
"Control character U+%04X not allowed in literal string at line %d"
582
-
(Char.code c) l.line)
601
+
Error.raise_lexer ~meta:(lexer_meta l) (Control_character (Char.code c))
583
602
584
603
let rec parse_multiline_literal_string l buf () =
585
-
if is_eof l then failwith "Unterminated literal string";
604
+
if is_eof l then Error.raise_lexer ~meta:(lexer_meta l) Unterminated_string;
586
605
let c = current l in
587
606
if c = '\'' then
588
607
handle_multiline_quotes l buf '\'' (parse_multiline_literal_string l buf)
···
592
611
if peek l = Some '\n' then (
593
612
Buffer.add_char buf '\n';
594
613
advance l)
595
-
else failwith "Bare carriage return not allowed in literal string"
614
+
else Error.raise_lexer ~meta:(lexer_meta l) Bare_carriage_return
596
615
end
597
616
else if Char.code c >= 0x80 then utf8_add_validated l buf
598
617
else begin
···
604
623
end
605
624
606
625
let rec parse_single_literal_string l buf () =
607
-
if is_eof l then failwith "Unterminated literal string";
626
+
if is_eof l then Error.raise_lexer ~meta:(lexer_meta l) Unterminated_string;
608
627
let c = current l in
609
628
if c = '\'' then advance l
610
629
else if c = '\n' || c = '\r' then
611
-
failwith "Newline not allowed in literal string"
630
+
Error.raise_lexer ~meta:(lexer_meta l) Newline_in_string
612
631
else begin
613
632
let code = Char.code c in
614
633
if code >= 0x80 then utf8_add_validated l buf
···
628
647
| Some "''" ->
629
648
advance l;
630
649
advance l;
631
-
skip_opening_newline l
632
-
"Bare carriage return not allowed in literal string";
650
+
skip_opening_newline l;
633
651
true
634
652
| _ -> false
635
653
in
···
639
657
640
658
(* Read a prefixed integer (0x/0o/0b) into [orig] (full token with
641
659
prefix) and [num] (digits only, no underscores). Caller has already
642
-
placed the '0' and prefix char into [orig]. *)
643
-
let read_prefixed_int l orig num is_valid_digit prefix fail_prefix fail_trailing
644
-
=
660
+
placed the '0' and prefix char into [orig]. [invalid_digit] names the
661
+
[number_error] variant produced when a character violates the radix. *)
662
+
let read_prefixed_int l orig num is_valid_digit invalid_digit =
645
663
advance l;
646
664
advance l;
647
665
(* skip 0x/0o/0b; prefix chars were already recorded by the caller *)
648
666
if peek l = Some '_' then
649
-
Fmt.failwith "Leading underscore not allowed after %s" prefix;
667
+
Error.raise_number ~meta:(lexer_meta l) Leading_underscore;
650
668
let rec read first =
651
669
match peek l with
652
670
| Some c when is_valid_digit c ->
···
656
674
read false
657
675
| Some '_' ->
658
676
if first then
659
-
Fmt.failwith "Underscore must follow a %s digit" fail_prefix;
677
+
Error.raise_number ~meta:(lexer_meta l) Underscore_not_between_digits;
660
678
Buffer.add_char orig '_';
661
679
advance l;
662
680
if peek l |> Option.map is_valid_digit |> Option.value ~default:false
663
681
then read false
664
-
else Fmt.failwith "Trailing underscore in %s number" fail_trailing
665
-
| _ ->
666
-
if first then
667
-
Fmt.failwith "Expected %s digit after %s" fail_prefix prefix
682
+
else Error.raise_number ~meta:(lexer_meta l) Trailing_underscore
683
+
| _ -> if first then Error.raise_number ~meta:(lexer_meta l) invalid_digit
668
684
in
669
685
read true
670
686
···
677
693
advance l;
678
694
read_int false
679
695
| Some '_' ->
680
-
if first then failwith "Underscore must follow a digit";
696
+
if first then
697
+
Error.raise_number ~meta:(lexer_meta l) Underscore_not_between_digits;
681
698
Buffer.add_char buf '_';
682
699
advance l;
683
700
if peek l |> Option.map is_digit |> Option.value ~default:false then
684
701
read_int false
685
-
else failwith "Trailing underscore in number"
686
-
| _ -> if first then failwith "Expected digit"
702
+
else Error.raise_number ~meta:(lexer_meta l) Trailing_underscore
703
+
| _ -> if first then Error.raise_number ~meta:(lexer_meta l) Missing_digit
687
704
in
688
705
read_int
689
706
···
693
710
let first_digit = peek l in
694
711
if first_digit = Some '0' then
695
712
begin match peek2 l with
696
-
| Some c when is_digit c -> failwith "Leading zeros not allowed"
697
-
| Some '_' -> failwith "Leading zeros not allowed"
713
+
| Some c when is_digit c ->
714
+
Error.raise_number ~meta:(lexer_meta l) Leading_zero
715
+
| Some '_' -> Error.raise_number ~meta:(lexer_meta l) Leading_zero
698
716
| _ -> ()
699
717
end;
700
718
let read_int = read_decimal_int l orig in
701
719
(match peek l with
702
720
| Some c when is_digit c -> read_int false
703
-
| _ -> failwith "Expected digit after sign");
721
+
| _ -> Error.raise_number ~meta:(lexer_meta l) Missing_digit_after_sign);
704
722
let is_float = ref false in
705
723
(match (peek l, peek2 l) with
706
724
| Some '.', Some c when is_digit c ->
···
708
726
Buffer.add_char orig '.';
709
727
advance l;
710
728
read_int false
711
-
| Some '.', _ -> failwith "Decimal point must be followed by digit"
729
+
| Some '.', _ ->
730
+
Error.raise_number ~meta:(lexer_meta l) Missing_digit_after_decimal
712
731
| _ -> ());
713
732
(match peek l with
714
733
| Some (('e' | 'E') as e) ->
···
721
740
advance l
722
741
| _ -> ());
723
742
(match peek l with
724
-
| Some '_' -> failwith "Underscore cannot follow exponent"
743
+
| Some '_' ->
744
+
Error.raise_number ~meta:(lexer_meta l) Underscore_after_exponent
725
745
| _ -> ());
726
746
read_int true
727
747
| _ -> ());
728
748
let s = Buffer.contents orig in
729
749
let s' = String.concat "" (String.split_on_char '_' s) in
730
-
if !is_float then Tok_float (float_of_string s', s)
731
-
else Tok_integer (Int64.of_string s', s)
750
+
if !is_float then
751
+
try Tok_float (float_of_string s', s)
752
+
with Failure _ -> Error.fail (lexer_meta l) "number out of range"
753
+
else
754
+
try Tok_integer (Int64.of_string s', s)
755
+
with Failure _ -> Error.fail (lexer_meta l) "integer out of range"
756
+
757
+
let int64_of_prefix l prefix digits =
758
+
try Int64.of_string (prefix ^ digits)
759
+
with Failure _ -> Error.fail (lexer_meta l) "integer out of range"
732
760
733
761
let parse_number l =
734
762
let orig = Buffer.create 16 in
···
760
788
| Some '0', Some 'x' when not neg ->
761
789
Buffer.add_string orig "0x";
762
790
let num = Buffer.create 16 in
763
-
read_prefixed_int l orig num is_hex_digit "0x" "hex" "hex";
791
+
read_prefixed_int l orig num is_hex_digit Error.Invalid_hex_digit;
764
792
let s = Buffer.contents num in
765
793
let o = Buffer.contents orig in
766
-
Tok_integer (Int64.of_string ("0x" ^ s), o)
794
+
Tok_integer (int64_of_prefix l "0x" s, o)
767
795
| Some '0', Some 'o' when not neg ->
768
796
Buffer.add_string orig "0o";
769
797
let num = Buffer.create 16 in
770
-
read_prefixed_int l orig num is_oct_digit "0o" "octal" "octal";
798
+
read_prefixed_int l orig num is_oct_digit Error.Invalid_octal_digit;
771
799
let s = Buffer.contents num in
772
800
let o = Buffer.contents orig in
773
-
Tok_integer (Int64.of_string ("0o" ^ s), o)
801
+
Tok_integer (int64_of_prefix l "0o" s, o)
774
802
| Some '0', Some 'b' when not neg ->
775
803
Buffer.add_string orig "0b";
776
804
let num = Buffer.create 16 in
777
-
read_prefixed_int l orig num is_bin_digit "0b" "binary" "binary";
805
+
read_prefixed_int l orig num is_bin_digit Error.Invalid_binary_digit;
778
806
let s = Buffer.contents num in
779
807
let o = Buffer.contents orig in
780
-
Tok_integer (Int64.of_string ("0b" ^ s), o)
808
+
Tok_integer (int64_of_prefix l "0b" s, o)
781
809
| _ -> parse_decimal_number l orig)
782
810
783
811
(* Check if we're looking at a datetime/date/time. These probe the
···
844
872
else if is_time_prefix l then `Time
845
873
else `Other
846
874
847
-
(* Date/time validation *)
848
-
let validate_date year month day =
849
-
if month < 1 || month > 12 then Fmt.failwith "Invalid month: %d" month;
850
-
if day < 1 then Fmt.failwith "Invalid day: %d" day;
875
+
(* Date/time validation. [meta] points at the token being validated so
876
+
range errors report against the offending date/time/offset. *)
877
+
let validate_date ~meta year month day =
878
+
if month < 1 || month > 12 then
879
+
Error.raise_datetime ~meta (Invalid_month month);
880
+
if day < 1 then Error.raise_datetime ~meta (Invalid_day (day, 0));
851
881
let days_in_month = [| 0; 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] in
852
882
let is_leap = (year mod 4 = 0 && year mod 100 <> 0) || year mod 400 = 0 in
853
883
let max_days = if month = 2 && is_leap then 29 else days_in_month.(month) in
854
-
if day > max_days then Fmt.failwith "Invalid day %d for month %d" day month
884
+
if day > max_days then Error.raise_datetime ~meta (Invalid_day (day, month))
855
885
856
-
let validate_time hour minute second =
857
-
if hour < 0 || hour > 23 then Fmt.failwith "Invalid hour: %d" hour;
858
-
if minute < 0 || minute > 59 then Fmt.failwith "Invalid minute: %d" minute;
886
+
let validate_time ~meta hour minute second =
887
+
if hour < 0 || hour > 23 then Error.raise_datetime ~meta (Invalid_hour hour);
888
+
if minute < 0 || minute > 59 then
889
+
Error.raise_datetime ~meta (Invalid_minute minute);
859
890
if second < 0 || second > 60 then (* 60 for leap second *)
860
-
Fmt.failwith "Invalid second: %d" second
891
+
Error.raise_datetime ~meta (Invalid_second second)
861
892
862
-
let validate_offset hour minute =
893
+
let validate_offset ~meta hour minute =
863
894
if hour < 0 || hour > 23 then
864
-
Fmt.failwith "Invalid timezone offset hour: %d" hour;
895
+
Error.raise_datetime ~meta (Invalid_timezone_offset_hour hour);
865
896
if minute < 0 || minute > 59 then
866
-
Fmt.failwith "Invalid timezone offset minute: %d" minute
897
+
Error.raise_datetime ~meta (Invalid_timezone_offset_minute minute)
867
898
868
-
let read_2_digits l buf secondary_buf fail_msg =
899
+
let read_2_digits l buf secondary_buf fmt_desc =
869
900
for _ = 1 to 2 do
870
901
match peek l with
871
902
| Some c when is_digit c ->
872
903
Buffer.add_char buf c;
873
904
Buffer.add_char secondary_buf c;
874
905
advance l
875
-
| _ -> failwith fail_msg
906
+
| _ -> Error.raise_datetime ~meta:(lexer_meta l) (Invalid_format fmt_desc)
876
907
done
877
908
878
909
let read_optional_seconds_frac l buf second_buf =
···
880
911
| Some ':' -> (
881
912
Buffer.add_char buf ':';
882
913
advance l;
883
-
read_2_digits l buf second_buf "Invalid time format";
914
+
read_2_digits l buf second_buf "time";
884
915
(* Optional fractional seconds *)
885
916
match peek l with
886
917
| Some '.' ->
887
918
Buffer.add_char buf '.';
888
919
advance l;
889
920
if not (peek l |> Option.map is_digit |> Option.value ~default:false)
890
-
then failwith "Expected digit after decimal point";
921
+
then
922
+
Error.raise_number ~meta:(lexer_meta l) Missing_digit_after_decimal;
891
923
while peek l |> Option.map is_digit |> Option.value ~default:false do
892
924
Buffer.add_char buf (Option.get (peek l));
893
925
advance l
···
899
931
Buffer.add_string second_buf "00"
900
932
901
933
let read_date_part l buf =
902
-
(* Read YYYY-MM-DD into buf, validate date components *)
934
+
(* Read YYYY-MM-DD into buf, validate date components. *)
935
+
let start_meta = lexer_meta l in
903
936
let year_buf = Buffer.create 4 in
904
937
let month_buf = Buffer.create 2 in
905
938
let day_buf = Buffer.create 2 in
···
909
942
Buffer.add_char buf c;
910
943
Buffer.add_char year_buf c;
911
944
advance l
912
-
| _ -> failwith "Invalid date format"
945
+
| _ -> Error.raise_datetime ~meta:(lexer_meta l) (Invalid_format "date")
913
946
done;
914
-
if peek l <> Some '-' then failwith "Invalid date format";
947
+
if peek l <> Some '-' then
948
+
Error.raise_datetime ~meta:(lexer_meta l) (Invalid_format "date");
915
949
Buffer.add_char buf '-';
916
950
advance l;
917
-
read_2_digits l buf month_buf "Invalid date format";
918
-
if peek l <> Some '-' then failwith "Invalid date format";
951
+
read_2_digits l buf month_buf "date";
952
+
if peek l <> Some '-' then
953
+
Error.raise_datetime ~meta:(lexer_meta l) (Invalid_format "date");
919
954
Buffer.add_char buf '-';
920
955
advance l;
921
-
read_2_digits l buf day_buf "Invalid date format";
956
+
read_2_digits l buf day_buf "date";
922
957
let year = int_of_string (Buffer.contents year_buf) in
923
958
let month = int_of_string (Buffer.contents month_buf) in
924
959
let day = int_of_string (Buffer.contents day_buf) in
925
-
validate_date year month day
960
+
validate_date ~meta:start_meta year month day
926
961
927
962
let read_tz_offset l buf =
928
963
(* Parse +HH:MM or -HH:MM offset, validate and append to buf *)
964
+
let start_meta = lexer_meta l in
929
965
let sign = current l in
930
966
let off_hour_buf = Buffer.create 2 in
931
967
let off_min_buf = Buffer.create 2 in
932
968
Buffer.add_char buf sign;
933
969
advance l;
934
-
read_2_digits l buf off_hour_buf "Invalid timezone offset";
935
-
if peek l <> Some ':' then failwith "Invalid timezone offset";
970
+
read_2_digits l buf off_hour_buf "timezone";
971
+
if peek l <> Some ':' then
972
+
Error.raise_datetime ~meta:(lexer_meta l) (Invalid_format "timezone");
936
973
Buffer.add_char buf ':';
937
974
advance l;
938
-
read_2_digits l buf off_min_buf "Invalid timezone offset";
975
+
read_2_digits l buf off_min_buf "timezone";
939
976
let off_hour = int_of_string (Buffer.contents off_hour_buf) in
940
977
let off_min = int_of_string (Buffer.contents off_min_buf) in
941
-
validate_offset off_hour off_min
978
+
validate_offset ~meta:start_meta off_hour off_min
942
979
943
980
let read_time_and_offset l buf =
944
981
(* Read HH:MM[:SS[.frac]] and optional offset, return datetime token *)
982
+
let time_meta = lexer_meta l in
945
983
let hour_buf = Buffer.create 2 in
946
984
let minute_buf = Buffer.create 2 in
947
985
let second_buf = Buffer.create 2 in
948
986
Buffer.add_char buf 'T';
949
987
(* normalize to uppercase T *)
950
-
read_2_digits l buf hour_buf "Invalid time format";
951
-
if peek l <> Some ':' then failwith "Invalid time format";
988
+
read_2_digits l buf hour_buf "time";
989
+
if peek l <> Some ':' then
990
+
Error.raise_datetime ~meta:(lexer_meta l) (Invalid_format "time");
952
991
Buffer.add_char buf ':';
953
992
advance l;
954
-
read_2_digits l buf minute_buf "Invalid time format";
993
+
read_2_digits l buf minute_buf "time";
955
994
read_optional_seconds_frac l buf second_buf;
956
995
let hour = int_of_string (Buffer.contents hour_buf) in
957
996
let minute = int_of_string (Buffer.contents minute_buf) in
···
960
999
int_of_string (Buffer.contents second_buf)
961
1000
else 0
962
1001
in
963
-
validate_time hour minute second;
1002
+
validate_time ~meta:time_meta hour minute second;
964
1003
match peek l with
965
1004
| Some 'Z' | Some 'z' ->
966
1005
Buffer.add_char buf 'Z';
···
993
1032
994
1033
let parse_time l =
995
1034
let buf = Buffer.create 16 in
1035
+
let time_meta = lexer_meta l in
996
1036
let hour_buf = Buffer.create 2 in
997
1037
let minute_buf = Buffer.create 2 in
998
1038
let second_buf = Buffer.create 2 in
999
1039
(* Read HH:MM *)
1000
-
read_2_digits l buf hour_buf "Invalid time format";
1001
-
if peek l <> Some ':' then failwith "Invalid time format";
1040
+
read_2_digits l buf hour_buf "time";
1041
+
if peek l <> Some ':' then
1042
+
Error.raise_datetime ~meta:(lexer_meta l) (Invalid_format "time");
1002
1043
Buffer.add_char buf ':';
1003
1044
advance l;
1004
-
read_2_digits l buf minute_buf "Invalid time format";
1045
+
read_2_digits l buf minute_buf "time";
1005
1046
read_optional_seconds_frac l buf second_buf;
1006
1047
(* Validate time *)
1007
1048
let hour = int_of_string (Buffer.contents hour_buf) in
···
1011
1052
int_of_string (Buffer.contents second_buf)
1012
1053
else 0
1013
1054
in
1014
-
validate_time hour minute second;
1055
+
validate_time ~meta:time_meta hour minute second;
1015
1056
Tok_time_local (Buffer.contents buf)
1016
1057
1017
1058
(* The following classifiers look ahead into the lookahead window,
···
1128
1169
read_bare_key_into l buf;
1129
1170
Tok_bare_key (Buffer.contents buf)
1130
1171
end
1131
-
else Fmt.failwith "Unexpected character after %c" sign
1172
+
else Error.raise_lexer ~meta:(lexer_meta l) (Unexpected_character sign)
1132
1173
| Some 'n' ->
1133
1174
if peek_n l 4 = Some (Fmt.str "%cnan" sign) then begin
1134
1175
advance_n l 4;
···
1140
1181
read_bare_key_into l buf;
1141
1182
Tok_bare_key (Buffer.contents buf)
1142
1183
end
1143
-
else Fmt.failwith "Unexpected character after %c" sign
1184
+
else Error.raise_lexer ~meta:(lexer_meta l) (Unexpected_character sign)
1144
1185
| _ when sign = '-' ->
1145
1186
let buf = Buffer.create 16 in
1146
1187
read_bare_key_into l buf;
1147
1188
Tok_bare_key (Buffer.contents buf)
1148
-
| _ -> Fmt.failwith "Unexpected character after %c" sign
1189
+
| _ -> Error.raise_lexer ~meta:(lexer_meta l) (Unexpected_character sign)
1149
1190
1150
1191
let lex_digit_token l =
1151
1192
match looks_like_datetime l with
···
1168
1209
end
1169
1210
else parse_number l
1170
1211
1212
+
(* Read a single token. Whitespace and comments must be skipped by the
1213
+
caller; the returned token's span is exactly the bytes consumed by
1214
+
this call. *)
1171
1215
let next_token l =
1172
-
skip_ws_and_comments l;
1173
1216
if is_eof l then Tok_eof
1174
1217
else begin
1175
1218
let c = current l in
···
1204
1247
advance l;
1205
1248
Tok_newline
1206
1249
end
1207
-
else Fmt.failwith "Bare carriage return not allowed at line %d" l.line
1250
+
else Error.raise_lexer ~meta:(lexer_meta l) Bare_carriage_return
1208
1251
| '"' ->
1209
1252
let s, multiline = parse_basic_string l in
1210
1253
if multiline then Tok_ml_basic_string s else Tok_basic_string s
···
1224
1267
| c ->
1225
1268
let code = Char.code c in
1226
1269
if code < 0x20 || code = 0x7F then
1227
-
Fmt.failwith "Control character U+%04X not allowed at line %d" code
1228
-
l.line
1229
-
else
1230
-
Fmt.failwith "Unexpected character '%c' at line %d, column %d" c
1231
-
l.line l.col
1270
+
Error.raise_lexer ~meta:(lexer_meta l) (Control_character code)
1271
+
else Error.raise_lexer ~meta:(lexer_meta l) (Unexpected_character c)
1232
1272
end
1233
1273
1234
1274
(* Parser *)
···
1236
1276
type parser = {
1237
1277
lexer : lexer;
1238
1278
mutable current : token;
1279
+
mutable current_meta : Loc.Meta.t;
1239
1280
mutable peeked : bool;
1240
1281
max_depth : int;
1241
1282
max_nodes : int;
···
1251
1292
{
1252
1293
lexer;
1253
1294
current = Tok_eof;
1295
+
current_meta = Loc.Meta.none;
1254
1296
peeked = false;
1255
1297
max_depth;
1256
1298
max_nodes;
···
1270
1312
if p.nodes > p.max_nodes then
1271
1313
Loc.Error.failf Loc.Meta.none "max nodes exceeded (limit: %d)" p.max_nodes
1272
1314
1315
+
(* Span a [Loc.Meta.t] from the lexer's pre-token position to its
1316
+
current post-token position. *)
1317
+
let token_meta l ~start_byte ~start_line ~start_line_byte =
1318
+
let last_byte = if l.byte > start_byte then l.byte - 1 else start_byte in
1319
+
let textloc =
1320
+
Loc.make ~file:l.file ~first_byte:start_byte ~last_byte
1321
+
~first_line_num:start_line ~first_line_byte:start_line_byte
1322
+
~last_line_num:l.line ~last_line_byte:l.line_byte
1323
+
in
1324
+
Loc.Meta.make textloc
1325
+
1326
+
let string_of_token = function
1327
+
| Tok_lbracket -> "["
1328
+
| Tok_rbracket -> "]"
1329
+
| Tok_lbrace -> "{"
1330
+
| Tok_rbrace -> "}"
1331
+
| Tok_equals -> "="
1332
+
| Tok_comma -> ","
1333
+
| Tok_dot -> "."
1334
+
| Tok_newline -> "newline"
1335
+
| Tok_eof -> "end of input"
1336
+
| Tok_bare_key s -> Fmt.str "bare key %S" s
1337
+
| Tok_basic_string s -> Fmt.str "basic string %S" s
1338
+
| Tok_literal_string s -> Fmt.str "literal string %S" s
1339
+
| Tok_ml_basic_string _ -> "multiline basic string"
1340
+
| Tok_ml_literal_string _ -> "multiline literal string"
1341
+
| Tok_integer (_, s) -> Fmt.str "integer %s" s
1342
+
| Tok_float (_, s) -> Fmt.str "float %s" s
1343
+
| Tok_datetime s -> Fmt.str "datetime %s" s
1344
+
| Tok_datetime_local s -> Fmt.str "local datetime %s" s
1345
+
| Tok_date_local s -> Fmt.str "local date %s" s
1346
+
| Tok_time_local s -> Fmt.str "local time %s" s
1347
+
1273
1348
let peek_token p =
1274
1349
if not p.peeked then begin
1275
-
p.current <- next_token p.lexer;
1350
+
skip_ws_and_comments p.lexer;
1351
+
let start_byte = p.lexer.byte in
1352
+
let start_line = p.lexer.line in
1353
+
let start_line_byte = p.lexer.line_byte in
1354
+
let tok = next_token p.lexer in
1355
+
p.current <- tok;
1356
+
p.current_meta <-
1357
+
token_meta p.lexer ~start_byte ~start_line ~start_line_byte;
1276
1358
p.peeked <- true
1277
1359
end;
1278
1360
p.current
···
1288
1370
let expect_token p expected =
1289
1371
let tok = consume_token p in
1290
1372
if tok <> expected then
1291
-
failwith
1292
-
(Fmt.str "Expected %s"
1293
-
(match expected with
1294
-
| Tok_equals -> "="
1295
-
| Tok_rbracket -> "]"
1296
-
| Tok_rbrace -> "}"
1297
-
| Tok_newline -> "newline"
1298
-
| _ -> "token"))
1373
+
let what =
1374
+
match expected with
1375
+
| Tok_equals -> "="
1376
+
| Tok_rbracket -> "]"
1377
+
| Tok_rbrace -> "}"
1378
+
| Tok_newline -> "newline"
1379
+
| _ -> "token"
1380
+
in
1381
+
Error.raise_syntax ~meta:p.current_meta (Expected what)
1299
1382
1300
1383
let skip_newlines p =
1301
1384
while peek_token p = Tok_newline do
1302
1385
ignore (consume_token p)
1303
1386
done
1304
1387
1305
-
(* Parse a single key segment (bare, basic string, literal string, or integer) *)
1388
+
(* Parse a single key segment (bare, basic string, literal string, or integer).
1389
+
Returns a list of [V.name] values: one key usually, several when a
1390
+
float-shaped token has an embedded dot. All segments from one token share
1391
+
the token's meta. *)
1306
1392
(* Note: Tok_float is handled specially in parse_dotted_key *)
1307
1393
let parse_key_segment p =
1308
-
match peek_token p with
1394
+
let tok = peek_token p in
1395
+
let meta = p.current_meta in
1396
+
let tag s = (s, meta) in
1397
+
match tok with
1309
1398
| Tok_bare_key s ->
1310
1399
ignore (consume_token p);
1311
-
[ s ]
1400
+
[ tag s ]
1312
1401
| Tok_basic_string s ->
1313
1402
ignore (consume_token p);
1314
-
[ s ]
1403
+
[ tag s ]
1315
1404
| Tok_literal_string s ->
1316
1405
ignore (consume_token p);
1317
-
[ s ]
1406
+
[ tag s ]
1318
1407
| Tok_integer (_i, orig_str) ->
1319
1408
ignore (consume_token p);
1320
-
[ orig_str ]
1409
+
[ tag orig_str ]
1321
1410
| Tok_float (f, orig_str) ->
1322
1411
(* Float in key context - use original string to preserve exact key parts *)
1323
1412
ignore (consume_token p);
1324
-
if Float.is_nan f then [ "nan" ]
1325
-
else if f = Float.infinity then [ "inf" ]
1326
-
else if f = Float.neg_infinity then [ "-inf" ]
1413
+
if Float.is_nan f then [ tag "nan" ]
1414
+
else if f = Float.infinity then [ tag "inf" ]
1415
+
else if f = Float.neg_infinity then [ tag "-inf" ]
1327
1416
else begin
1328
1417
(* Remove underscores from original string and split on dot *)
1329
1418
let s = String.concat "" (String.split_on_char '_' orig_str) in
1330
-
if String.contains s 'e' || String.contains s 'E' then
1331
-
(* Has exponent, treat as single key *)
1332
-
[ s ]
1419
+
if String.contains s 'e' || String.contains s 'E' then [ tag s ]
1333
1420
else if String.contains s '.' then
1334
-
(* Split on decimal point for dotted key *)
1335
-
String.split_on_char '.' s
1336
-
else
1337
-
(* No decimal point, single integer key *)
1338
-
[ s ]
1421
+
List.map tag (String.split_on_char '.' s)
1422
+
else [ tag s ]
1339
1423
end
1340
1424
| Tok_date_local s ->
1341
1425
ignore (consume_token p);
1342
-
[ s ]
1426
+
[ tag s ]
1343
1427
| Tok_datetime s ->
1344
1428
ignore (consume_token p);
1345
-
[ s ]
1429
+
[ tag s ]
1346
1430
| Tok_datetime_local s ->
1347
1431
ignore (consume_token p);
1348
-
[ s ]
1432
+
[ tag s ]
1349
1433
| Tok_time_local s ->
1350
1434
ignore (consume_token p);
1351
-
[ s ]
1435
+
[ tag s ]
1352
1436
| Tok_ml_basic_string _ ->
1353
-
failwith "Multiline strings are not allowed as keys"
1437
+
Error.raise_semantic ~meta:p.current_meta Multiline_key
1354
1438
| Tok_ml_literal_string _ ->
1355
-
failwith "Multiline strings are not allowed as keys"
1356
-
| _ -> failwith "Expected key"
1439
+
Error.raise_semantic ~meta:p.current_meta Multiline_key
1440
+
| _ -> Error.raise_syntax ~meta:p.current_meta (Expected "key")
1357
1441
1358
-
(* Parse a dotted key - returns list of key strings *)
1442
+
(* Parse a dotted key - returns list of names. *)
1359
1443
let parse_dotted_key p =
1360
1444
let first_keys = parse_key_segment p in
1361
1445
let rec loop acc =
···
1369
1453
let rest = loop [] in
1370
1454
first_keys @ rest
1371
1455
1372
-
let validate_number_underscores str =
1456
+
let validate_number_underscores ~meta str =
1373
1457
let len = String.length str in
1374
-
if len > 0 && str.[0] = '_' then
1375
-
failwith "Leading underscore not allowed in number";
1458
+
if len > 0 && str.[0] = '_' then Error.raise_number ~meta Leading_underscore;
1376
1459
if len > 0 && str.[len - 1] = '_' then
1377
-
failwith "Trailing underscore not allowed in number";
1460
+
Error.raise_number ~meta Trailing_underscore;
1378
1461
let has_hex_prefix =
1379
1462
len > 2 && str.[0] = '0' && (str.[1] = 'x' || str.[1] = 'X')
1380
1463
in
···
1384
1467
in
1385
1468
for i = 0 to len - 2 do
1386
1469
if str.[i] = '_' && str.[i + 1] = '_' then
1387
-
failwith "Double underscore not allowed in number";
1470
+
Error.raise_number ~meta Double_underscore;
1388
1471
if str.[i] = '_' then begin
1389
1472
let prev = if i > 0 then Some str.[i - 1] else None in
1390
1473
let next = Some str.[i + 1] in
···
1392
1475
| Some p, Some n when has_hex_prefix && is_hex_char p && is_hex_char n ->
1393
1476
()
1394
1477
| Some p, Some n when is_digit_char p && is_digit_char n -> ()
1395
-
| _ -> failwith "Underscore must be between digits"
1478
+
| _ -> Error.raise_number ~meta Underscore_not_between_digits
1396
1479
end
1397
1480
done
1398
1481
1399
-
let bare_key_as_number s =
1400
-
validate_number_underscores s;
1482
+
let bare_key_as_number ~meta s =
1483
+
validate_number_underscores ~meta s;
1401
1484
let s_no_underscore = String.concat "" (String.split_on_char '_' s) in
1402
1485
let len = String.length s_no_underscore in
1403
-
if len = 0 then Fmt.failwith "Unexpected bare key '%s' as value" s;
1486
+
if len = 0 then Error.raise_syntax ~meta (Unexpected_bare_key s);
1404
1487
let c0 = s_no_underscore.[0] in
1405
-
if c0 < '0' || c0 > '9' then
1406
-
Fmt.failwith "Unexpected bare key '%s' as value" s;
1488
+
if c0 < '0' || c0 > '9' then Error.raise_syntax ~meta (Unexpected_bare_key s);
1407
1489
if
1408
1490
len > 1 && c0 = '0'
1409
1491
&& s_no_underscore.[1] >= '0'
1410
1492
&& s_no_underscore.[1] <= '9'
1411
-
then failwith "Leading zeros not allowed";
1493
+
then Error.raise_number ~meta Leading_zero;
1412
1494
try
1413
1495
if
1414
1496
String.contains s_no_underscore '.'
1415
1497
|| String.contains s_no_underscore 'e'
1416
1498
|| String.contains s_no_underscore 'E'
1417
-
then V.Float (float_of_string s_no_underscore)
1418
-
else V.Int (Int64.of_string s_no_underscore)
1419
-
with Failure _ -> Fmt.failwith "Unexpected bare key '%s' as value" s
1499
+
then V.Float (float_of_string s_no_underscore, meta)
1500
+
else V.Int (Int64.of_string s_no_underscore, meta)
1501
+
with Failure _ -> Error.raise_syntax ~meta (Unexpected_bare_key s)
1420
1502
1421
1503
let rec parse_value p =
1422
1504
limits_bump_node p;
1423
-
match peek_token p with
1505
+
let tok = peek_token p in
1506
+
let meta = p.current_meta in
1507
+
match tok with
1424
1508
| Tok_basic_string s ->
1425
1509
ignore (consume_token p);
1426
-
V.String s
1510
+
V.String (s, meta)
1427
1511
| Tok_literal_string s ->
1428
1512
ignore (consume_token p);
1429
-
V.String s
1513
+
V.String (s, meta)
1430
1514
| Tok_ml_basic_string s ->
1431
1515
ignore (consume_token p);
1432
-
V.String s
1516
+
V.String (s, meta)
1433
1517
| Tok_ml_literal_string s ->
1434
1518
ignore (consume_token p);
1435
-
V.String s
1519
+
V.String (s, meta)
1436
1520
| Tok_integer (i, _) ->
1437
1521
ignore (consume_token p);
1438
-
V.Int i
1522
+
V.Int (i, meta)
1439
1523
| Tok_float (f, _) ->
1440
1524
ignore (consume_token p);
1441
-
V.Float f
1525
+
V.Float (f, meta)
1442
1526
| Tok_datetime s ->
1443
1527
ignore (consume_token p);
1444
-
V.Datetime s
1528
+
V.Datetime (s, meta)
1445
1529
| Tok_datetime_local s ->
1446
1530
ignore (consume_token p);
1447
-
V.Datetime_local s
1531
+
V.Datetime_local (s, meta)
1448
1532
| Tok_date_local s ->
1449
1533
ignore (consume_token p);
1450
-
V.Date_local s
1534
+
V.Date_local (s, meta)
1451
1535
| Tok_time_local s ->
1452
1536
ignore (consume_token p);
1453
-
V.Time_local s
1537
+
V.Time_local (s, meta)
1454
1538
| Tok_lbracket -> parse_array p
1455
1539
| Tok_lbrace -> parse_inline_table p
1456
1540
| Tok_bare_key s -> (
1457
1541
ignore (consume_token p);
1458
1542
match s with
1459
-
| "true" -> Bool true
1460
-
| "false" -> Bool false
1461
-
| "inf" -> Float Float.infinity
1462
-
| "nan" -> Float Float.nan
1463
-
| _ -> bare_key_as_number s)
1464
-
| _ -> failwith "Expected value"
1543
+
| "true" -> Bool (true, meta)
1544
+
| "false" -> Bool (false, meta)
1545
+
| "inf" -> Float (Float.infinity, meta)
1546
+
| "nan" -> Float (Float.nan, meta)
1547
+
| _ -> bare_key_as_number ~meta s)
1548
+
| _ -> Error.raise_syntax ~meta:p.current_meta (Expected "value")
1465
1549
1466
1550
and parse_array p =
1551
+
let start_meta = p.current_meta in
1467
1552
ignore (consume_token p);
1468
1553
(* [ *)
1469
1554
limits_enter p;
···
1473
1558
| Tok_rbracket ->
1474
1559
ignore (consume_token p);
1475
1560
limits_leave p;
1476
-
V.Array (List.rev acc)
1561
+
V.Array (List.rev acc, start_meta)
1477
1562
| _ -> (
1478
1563
let v = parse_value p in
1479
1564
skip_newlines p;
···
1485
1570
| Tok_rbracket ->
1486
1571
ignore (consume_token p);
1487
1572
limits_leave p;
1488
-
V.Array (List.rev (v :: acc))
1489
-
| _ -> failwith "Expected ',' or ']' in array")
1573
+
V.Array (List.rev (v :: acc), start_meta)
1574
+
| _ ->
1575
+
Error.raise_syntax ~meta:p.current_meta
1576
+
(Expected "',' or ']' in array"))
1490
1577
in
1491
1578
loop []
1492
1579
1493
1580
and parse_inline_table p =
1581
+
let start_meta = p.current_meta in
1494
1582
ignore (consume_token p);
1495
1583
(* { *)
1496
1584
limits_enter p;
1497
1585
skip_newlines p;
1498
-
(* Track explicitly defined keys - can't be extended with dotted keys *)
1586
+
(* Track explicitly defined keys by their string part - can't be extended
1587
+
with dotted keys *)
1499
1588
let defined_inline = ref [] in
1500
1589
let rec loop acc =
1501
1590
match peek_token p with
1502
1591
| Tok_rbrace ->
1503
1592
ignore (consume_token p);
1504
1593
limits_leave p;
1505
-
V.Table (List.rev acc)
1594
+
V.Table (List.rev acc, start_meta)
1506
1595
| _ -> (
1507
1596
let keys = parse_dotted_key p in
1508
1597
skip_ws p;
···
1511
1600
let v = parse_value p in
1512
1601
(* Check if trying to extend a previously-defined inline table *)
1513
1602
(match keys with
1514
-
| first_key :: _ :: _ ->
1515
-
(* Multi-key dotted path - check if first key is already defined *)
1603
+
| (first_key, _) :: _ :: _ ->
1516
1604
if List.mem first_key !defined_inline then
1517
-
failwith
1518
-
(Fmt.str "Cannot extend inline table '%s' with dotted key"
1519
-
first_key)
1605
+
Error.raise_semantic ~meta:p.current_meta
1606
+
(Cannot_extend_inline_table first_key)
1520
1607
| _ -> ());
1521
1608
(* If this is a direct assignment to a key, track it *)
1522
1609
(match keys with
1523
-
| [ k ] ->
1610
+
| [ (k, _) ] ->
1524
1611
if List.mem k !defined_inline then
1525
-
Fmt.failwith "Duplicate key '%s' in inline table" k;
1612
+
Error.raise_semantic ~meta:p.current_meta (Duplicate_key k);
1526
1613
defined_inline := k :: !defined_inline
1527
1614
| _ -> ());
1528
1615
let entry = build_nested_table keys v in
1529
-
(* Merge the entry with existing entries (for dotted keys with common prefix) *)
1530
1616
let acc = merge_entry_into_table acc entry in
1531
1617
skip_newlines p;
1532
1618
match peek_token p with
···
1537
1623
| Tok_rbrace ->
1538
1624
ignore (consume_token p);
1539
1625
limits_leave p;
1540
-
V.Table (List.rev acc)
1541
-
| _ -> failwith "Expected ',' or '}' in inline table")
1626
+
V.Table (List.rev acc, start_meta)
1627
+
| _ ->
1628
+
Error.raise_syntax ~meta:p.current_meta
1629
+
(Expected "',' or '}' in inline table"))
1542
1630
in
1543
1631
loop []
1544
1632
···
1548
1636
1549
1637
and build_nested_table keys value =
1550
1638
match keys with
1551
-
| [] -> failwith "Empty key"
1639
+
| [] -> Error.raise_semantic ~meta:(V.meta value) Empty_key
1552
1640
| [ k ] -> (k, value)
1553
-
| k :: rest -> (k, V.Table [ build_nested_table rest value ])
1641
+
| k :: rest -> (k, V.Table ([ build_nested_table rest value ], V.Meta.none))
1554
1642
1555
-
(* Merge two TOML values - used for combining dotted keys in inline tables *)
1643
+
(* Merge two TOML values - used for combining dotted keys in inline tables.
1644
+
Key comparison is on the string part; metadata is preserved from the
1645
+
first-seen key. *)
1556
1646
and merge_toml_values v1 v2 =
1557
1647
match (v1, v2) with
1558
-
| V.Table entries1, V.Table entries2 ->
1559
-
(* Merge the entries *)
1648
+
| V.Table (entries1, m), V.Table (entries2, _) ->
1649
+
let find_by_name k = List.find_opt (fun ((k', _), _) -> k = k') in
1650
+
let remove_by_name k = List.filter (fun ((k', _), _) -> k <> k') in
1560
1651
let merged =
1561
1652
List.fold_left
1562
-
(fun acc (k, v) ->
1563
-
match List.assoc_opt k acc with
1564
-
| Some existing ->
1565
-
(* Key exists - try to merge if both are tables *)
1653
+
(fun acc (((name, _) as kn), v) ->
1654
+
match find_by_name name acc with
1655
+
| Some (_, existing) ->
1566
1656
let merged_v = merge_toml_values existing v in
1567
-
(k, merged_v) :: List.remove_assoc k acc
1568
-
| None -> (k, v) :: acc)
1657
+
(kn, merged_v) :: remove_by_name name acc
1658
+
| None -> (kn, v) :: acc)
1569
1659
entries1 entries2
1570
1660
in
1571
-
V.Table (List.rev merged)
1572
-
| _, _ ->
1573
-
(* Can't merge non-table values with same key *)
1574
-
failwith "Conflicting keys in inline table"
1661
+
V.Table (List.rev merged, m)
1662
+
| _, _ -> Error.raise_semantic ~meta:(V.meta v2) Conflicting_keys
1575
1663
1576
1664
(* Merge a single entry into an existing table *)
1577
-
and merge_entry_into_table entries (k, v) =
1578
-
match List.assoc_opt k entries with
1579
-
| Some existing ->
1665
+
and merge_entry_into_table entries (((name, _) as kn), v) =
1666
+
let find_by_name k = List.find_opt (fun ((k', _), _) -> k = k') in
1667
+
let remove_by_name k = List.filter (fun ((k', _), _) -> k <> k') in
1668
+
match find_by_name name entries with
1669
+
| Some (_, existing) ->
1580
1670
let merged_v = merge_toml_values existing v in
1581
-
(k, merged_v) :: List.remove_assoc k entries
1582
-
| None -> (k, v) :: entries
1671
+
(kn, merged_v) :: remove_by_name name entries
1672
+
| None -> (kn, v) :: entries
1583
1673
1674
+
(* The [validate_*_string] helpers re-validate dates/times encoded as
1675
+
strings inside parsed TOML values, from the Tagged_json encoder path
1676
+
(TOML -> tagged JSON, used by the toml-test harness). At this point
1677
+
we have no lexer context, so we attach [Loc.Meta.none]. *)
1584
1678
let validate_datetime_string s =
1585
-
(* Parse and validate date portion *)
1679
+
let meta = Loc.Meta.none in
1586
1680
if String.length s >= 10 then begin
1587
1681
let year = int_of_string (String.sub s 0 4) in
1588
1682
let month = int_of_string (String.sub s 5 2) in
1589
1683
let day = int_of_string (String.sub s 8 2) in
1590
-
validate_date year month day;
1591
-
(* Parse and validate time portion if present *)
1684
+
validate_date ~meta year month day;
1592
1685
if String.length s >= 16 then begin
1593
1686
let time_start =
1594
1687
if s.[10] = 'T' || s.[10] = 't' || s.[10] = ' ' then 11 else 10
···
1600
1693
int_of_string (String.sub s (time_start + 6) 2)
1601
1694
else 0
1602
1695
in
1603
-
validate_time hour minute second
1696
+
validate_time ~meta hour minute second
1604
1697
end
1605
1698
end
1606
1699
1607
1700
let validate_date_string s =
1701
+
let meta = Loc.Meta.none in
1608
1702
if String.length s >= 10 then begin
1609
1703
let year = int_of_string (String.sub s 0 4) in
1610
1704
let month = int_of_string (String.sub s 5 2) in
1611
1705
let day = int_of_string (String.sub s 8 2) in
1612
-
validate_date year month day
1706
+
validate_date ~meta year month day
1613
1707
end
1614
1708
1615
1709
let validate_time_string s =
1710
+
let meta = Loc.Meta.none in
1616
1711
if String.length s >= 5 then begin
1617
1712
let hour = int_of_string (String.sub s 0 2) in
1618
1713
let minute = int_of_string (String.sub s 3 2) in
···
1621
1716
int_of_string (String.sub s 6 2)
1622
1717
else 0
1623
1718
in
1624
-
validate_time hour minute second
1719
+
validate_time ~meta hour minute second
1625
1720
end
1626
1721
1627
1722
(* Table management for the parser *)
···
1647
1742
array_elements = [];
1648
1743
}
1649
1744
1650
-
let rec ensure_table state keys create_intermediate =
1745
+
let rec ensure_table ~meta state keys create_intermediate =
1651
1746
match keys with
1652
1747
| [] -> state
1653
1748
| [ k ] -> (
1654
1749
(* Check if key exists as a value *)
1655
1750
if List.mem_assoc k state.values then
1656
-
Fmt.failwith "Cannot use value '%s' as a table" k;
1751
+
Error.raise_semantic ~meta (Cannot_use_value_as_table k);
1657
1752
match Hashtbl.find_opt state.subtables k with
1658
1753
| Some sub -> sub
1659
1754
| None ->
···
1663
1758
| k :: rest ->
1664
1759
(* Check if key exists as a value *)
1665
1760
if List.mem_assoc k state.values then
1666
-
Fmt.failwith "Cannot use value '%s' as a table" k;
1761
+
Error.raise_semantic ~meta (Cannot_use_value_as_table k);
1667
1762
let sub =
1668
1763
match Hashtbl.find_opt state.subtables k with
1669
1764
| Some sub -> sub
···
1674
1769
in
1675
1770
if create_intermediate && not sub.defined then sub.defined <- false;
1676
1771
(* Mark as implicitly defined *)
1677
-
ensure_table sub rest create_intermediate
1772
+
ensure_table ~meta sub rest create_intermediate
1678
1773
1679
-
(* Like ensure_table but marks tables as defined (for dotted keys) *)
1680
-
(* Dotted keys mark tables as "defined" (can't re-define with [table]) but not "closed" *)
1681
-
let rec table_for_dotted_key state keys =
1774
+
(* Like ensure_table but marks tables as defined (for dotted keys).
1775
+
Dotted keys mark tables as "defined" (can't re-define with [table])
1776
+
but not "closed". *)
1777
+
let rec table_for_dotted_key ~meta state keys =
1682
1778
match keys with
1683
1779
| [] -> state
1684
1780
| [ k ] -> (
1685
-
(* Check if key exists as a value *)
1686
1781
if List.mem_assoc k state.values then
1687
-
Fmt.failwith "Cannot use value '%s' as a table" k;
1782
+
Error.raise_semantic ~meta (Cannot_use_value_as_table k);
1688
1783
match Hashtbl.find_opt state.subtables k with
1689
1784
| Some sub ->
1690
-
(* Check if it's an array of tables (can't extend with dotted keys) *)
1691
1785
if sub.is_array then
1692
-
failwith
1693
-
(Fmt.str "Cannot extend array of tables '%s' using dotted keys" k);
1694
-
(* Check if it's closed (explicitly defined with [table] header) *)
1786
+
Error.raise_semantic ~meta (Cannot_extend_array_of_tables k);
1695
1787
if sub.closed then
1696
-
Fmt.failwith "Cannot extend table '%s' using dotted keys" k;
1697
-
if sub.is_inline then Fmt.failwith "Cannot extend inline table '%s'" k;
1698
-
(* Mark as defined by dotted key *)
1788
+
Error.raise_semantic ~meta (Cannot_extend_closed_table k);
1789
+
if sub.is_inline then
1790
+
Error.raise_semantic ~meta (Cannot_extend_inline_table k);
1699
1791
sub.defined <- true;
1700
1792
sub
1701
1793
| None ->
1702
1794
let sub = table_state () in
1703
1795
sub.defined <- true;
1704
-
(* Mark as defined by dotted key *)
1705
1796
Hashtbl.add state.subtables k sub;
1706
1797
sub)
1707
1798
| k :: rest ->
1708
-
(* Check if key exists as a value *)
1709
1799
if List.mem_assoc k state.values then
1710
-
Fmt.failwith "Cannot use value '%s' as a table" k;
1800
+
Error.raise_semantic ~meta (Cannot_use_value_as_table k);
1711
1801
let sub =
1712
1802
match Hashtbl.find_opt state.subtables k with
1713
1803
| Some sub ->
1714
-
(* Check if it's an array of tables (can't extend with dotted keys) *)
1715
1804
if sub.is_array then
1716
-
failwith
1717
-
(Fmt.str "Cannot extend array of tables '%s' using dotted keys"
1718
-
k);
1805
+
Error.raise_semantic ~meta (Cannot_extend_array_of_tables k);
1719
1806
if sub.closed then
1720
-
Fmt.failwith "Cannot extend table '%s' using dotted keys" k;
1807
+
Error.raise_semantic ~meta (Cannot_extend_closed_table k);
1721
1808
if sub.is_inline then
1722
-
Fmt.failwith "Cannot extend inline table '%s'" k;
1723
-
(* Mark as defined by dotted key *)
1809
+
Error.raise_semantic ~meta (Cannot_extend_inline_table k);
1724
1810
sub.defined <- true;
1725
1811
sub
1726
1812
| None ->
1727
1813
let sub = table_state () in
1728
1814
sub.defined <- true;
1729
-
(* Mark as defined by dotted key *)
1730
1815
Hashtbl.add state.subtables k sub;
1731
1816
sub
1732
1817
in
1733
-
table_for_dotted_key sub rest
1818
+
table_for_dotted_key ~meta sub rest
1734
1819
1735
1820
let rec table_state_to_toml state =
1736
1821
let subtable_values =
···
1738
1823
(fun k sub acc ->
1739
1824
let v =
1740
1825
if sub.is_array then
1741
-
V.Array (List.map table_state_to_toml (array_elements sub))
1826
+
V.Array
1827
+
(List.map table_state_to_toml (array_elements sub), V.Meta.none)
1742
1828
else table_state_to_toml sub
1743
1829
in
1744
-
(k, v) :: acc)
1830
+
((k, V.Meta.none), v) :: acc)
1745
1831
state.subtables []
1746
1832
in
1747
-
V.Table (List.rev state.values @ subtable_values)
1833
+
let values = List.map (fun (k, v) -> ((k, V.Meta.none), v)) state.values in
1834
+
V.Table (List.rev values @ subtable_values, V.Meta.none)
1748
1835
1749
1836
and array_elements state = List.rev state.array_elements
1750
1837
···
1760
1847
| [], _ -> []
1761
1848
| _ :: krest, _ :: prest -> remove_key_prefix krest prest
1762
1849
1763
-
let check_array_table_conflict array_table keys =
1850
+
let check_array_table_conflict ~meta array_table keys =
1851
+
let name = String.concat "." keys in
1764
1852
if array_table.defined && not array_table.is_array then
1765
-
Fmt.failwith
1766
-
"Cannot define '%s' as array of tables; already defined as table"
1767
-
(String.concat "." keys);
1853
+
Error.raise_semantic ~meta (Cannot_convert_table_to_array name);
1768
1854
if
1769
1855
(array_table.values <> [] || Hashtbl.length array_table.subtables > 0)
1770
1856
&& not array_table.is_array
1771
-
then
1772
-
Fmt.failwith "Cannot define '%s' as array of tables; already has content"
1773
-
(String.concat "." keys)
1857
+
then Error.raise_semantic ~meta (Table_has_content name)
1774
1858
1775
-
let define_table_header table keys =
1859
+
let define_table_header ~meta table keys =
1860
+
let name = String.concat "." keys in
1776
1861
if table.is_array then
1777
-
Fmt.failwith
1778
-
"Cannot define '%s' as table; already defined as array of tables"
1779
-
(String.concat "." keys);
1780
-
if table.defined then
1781
-
Fmt.failwith "Table '%s' already defined" (String.concat "." keys);
1862
+
Error.raise_semantic ~meta (Cannot_convert_array_to_table name);
1863
+
if table.defined then Error.raise_semantic ~meta (Table_already_defined name);
1782
1864
table.defined <- true;
1783
1865
table.closed <- true
1784
1866
1785
-
let add_value_to_table tbl key v =
1786
-
if List.mem_assoc key tbl.values then Fmt.failwith "Duplicate key: %s" key;
1867
+
let add_value_to_table ~meta tbl key v =
1868
+
if List.mem_assoc key tbl.values then
1869
+
Error.raise_semantic ~meta (Duplicate_key key);
1787
1870
(match Hashtbl.find_opt tbl.subtables key with
1788
1871
| Some sub ->
1789
1872
if sub.is_array then
1790
-
Fmt.failwith "Cannot redefine array of tables '%s' as a value" key
1791
-
else Fmt.failwith "Cannot redefine table '%s' as a value" key
1873
+
Error.raise_semantic ~meta (Cannot_redefine_array_as_value key)
1874
+
else Error.raise_semantic ~meta (Cannot_redefine_table_as_value key)
1792
1875
| None -> ());
1793
1876
tbl.values <- (key, v) :: tbl.values
1794
1877
···
1825
1908
pop_invalid_contexts ds keys
1826
1909
end
1827
1910
1828
-
let handle_array_of_tables ds keys =
1911
+
let handle_array_of_tables ~meta ds keys =
1829
1912
pop_invalid_contexts ds keys;
1830
1913
match array_context ds keys with
1831
1914
| Some (`Sibling (_path, _parent, container)) ->
···
1834
1917
ds.current_table <- new_entry
1835
1918
| Some (`Nested (parent_path, parent_entry)) ->
1836
1919
let relative_keys = remove_key_prefix keys parent_path in
1837
-
let array_table = ensure_table parent_entry relative_keys true in
1838
-
check_array_table_conflict array_table keys;
1920
+
let array_table = ensure_table ~meta parent_entry relative_keys true in
1921
+
check_array_table_conflict ~meta array_table keys;
1839
1922
array_table.is_array <- true;
1840
1923
let new_entry = table_state () in
1841
1924
array_table.array_elements <- new_entry :: array_table.array_elements;
···
1843
1926
ds.array_context_stack :=
1844
1927
(keys, parent_entry, array_table) :: !(ds.array_context_stack)
1845
1928
| None ->
1846
-
let array_table = ensure_table ds.root keys true in
1847
-
check_array_table_conflict array_table keys;
1929
+
let array_table = ensure_table ~meta ds.root keys true in
1930
+
check_array_table_conflict ~meta array_table keys;
1848
1931
array_table.is_array <- true;
1849
1932
let entry = table_state () in
1850
1933
array_table.array_elements <- entry :: array_table.array_elements;
···
1852
1935
ds.array_context_stack :=
1853
1936
(keys, ds.root, array_table) :: !(ds.array_context_stack)
1854
1937
1855
-
let handle_table_header ds keys =
1938
+
let handle_table_header ~meta ds keys =
1856
1939
pop_invalid_contexts ds keys;
1940
+
let name () = String.concat "." keys in
1857
1941
match array_context ds keys with
1858
1942
| Some (`Nested (parent_path, parent_entry)) ->
1859
1943
let relative_keys = remove_key_prefix keys parent_path in
1860
1944
let table =
1861
-
if relative_keys <> [] then ensure_table parent_entry relative_keys true
1862
-
else ensure_table ds.root keys true
1945
+
if relative_keys <> [] then
1946
+
ensure_table ~meta parent_entry relative_keys true
1947
+
else ensure_table ~meta ds.root keys true
1863
1948
in
1864
-
define_table_header table keys;
1949
+
define_table_header ~meta table keys;
1865
1950
ds.current_table <- table
1866
1951
| Some (`Sibling (_, _, container)) ->
1867
1952
if container.is_array then
1868
-
Fmt.failwith
1869
-
"Cannot define '%s' as table; already defined as array of tables"
1870
-
(String.concat "." keys);
1871
-
let table = ensure_table ds.root keys true in
1953
+
Error.raise_semantic ~meta (Cannot_convert_array_to_table (name ()));
1954
+
let table = ensure_table ~meta ds.root keys true in
1872
1955
if table.defined then
1873
-
Fmt.failwith "Table '%s' already defined" (String.concat "." keys);
1956
+
Error.raise_semantic ~meta (Table_already_defined (name ()));
1874
1957
table.defined <- true;
1875
1958
table.closed <- true;
1876
1959
ds.current_table <- table
1877
1960
| None ->
1878
-
let table = ensure_table ds.root keys true in
1879
-
define_table_header table keys;
1961
+
let table = ensure_table ~meta ds.root keys true in
1962
+
define_table_header ~meta table keys;
1880
1963
ds.current_table <- table;
1881
1964
if
1882
1965
not
···
1895
1978
match peek_token parser with
1896
1979
| Tok_eof -> ()
1897
1980
| Tok_lbracket -> (
1981
+
let header_meta = parser.current_meta in
1898
1982
ignore (consume_token parser);
1899
1983
let is_adjacent_bracket = next_raw_char_is parser '[' in
1900
1984
match peek_token parser with
1901
1985
| Tok_lbracket when not is_adjacent_bracket ->
1902
-
failwith "Invalid table header syntax"
1986
+
Error.raise_syntax ~meta:parser.current_meta Invalid_table_header
1903
1987
| Tok_lbracket ->
1904
1988
ignore (consume_token parser);
1905
-
let keys = parse_dotted_key parser in
1989
+
let keys = List.map fst (parse_dotted_key parser) in
1906
1990
expect_token parser Tok_rbracket;
1907
1991
if not (next_raw_char_is parser ']') then
1908
-
failwith "Invalid array of tables syntax (space in ]])";
1992
+
Error.raise_syntax ~meta:parser.current_meta
1993
+
Invalid_array_of_tables_header;
1909
1994
expect_token parser Tok_rbracket;
1910
1995
skip_to_newline parser;
1911
-
handle_array_of_tables ds keys;
1996
+
handle_array_of_tables ~meta:header_meta ds keys;
1912
1997
parse_document ()
1913
1998
| _ ->
1914
-
let keys = parse_dotted_key parser in
1999
+
let keys = List.map fst (parse_dotted_key parser) in
1915
2000
expect_token parser Tok_rbracket;
1916
2001
skip_to_newline parser;
1917
-
handle_table_header ds keys;
2002
+
handle_table_header ~meta:header_meta ds keys;
1918
2003
parse_document ())
1919
2004
| Tok_bare_key _ | Tok_basic_string _ | Tok_literal_string _ | Tok_integer _
1920
2005
| Tok_float _ | Tok_date_local _ | Tok_datetime _ | Tok_datetime_local _
1921
2006
| Tok_time_local _ ->
1922
-
let keys = parse_dotted_key parser in
2007
+
let key_meta = parser.current_meta in
2008
+
let keys = List.map fst (parse_dotted_key parser) in
1923
2009
expect_token parser Tok_equals;
1924
2010
let value = parse_value parser in
1925
2011
skip_to_newline parser;
1926
2012
(match keys with
1927
-
| [] -> failwith "Empty key"
1928
-
| [ k ] -> add_value_to_table ds.current_table k value
2013
+
| [] -> Error.raise_semantic ~meta:key_meta Empty_key
2014
+
| [ k ] -> add_value_to_table ~meta:key_meta ds.current_table k value
1929
2015
| _ ->
1930
2016
let parent_keys = List.rev (List.tl (List.rev keys)) in
1931
2017
let final_key = List.hd (List.rev keys) in
1932
-
let parent = table_for_dotted_key ds.current_table parent_keys in
1933
-
add_value_to_table parent final_key value);
2018
+
let parent =
2019
+
table_for_dotted_key ~meta:key_meta ds.current_table parent_keys
2020
+
in
2021
+
add_value_to_table ~meta:key_meta parent final_key value);
1934
2022
parse_document ()
1935
-
| _tok -> Fmt.failwith "Unexpected token at line %d" parser.lexer.line
2023
+
| _ ->
2024
+
let tok = peek_token parser in
2025
+
Error.raise_syntax ~meta:parser.current_meta
2026
+
(Unexpected_token (string_of_token tok))
1936
2027
and skip_to_newline parser =
1937
2028
skip_ws_and_comments parser.lexer;
1938
2029
match peek_token parser with
1939
2030
| Tok_newline -> ignore (consume_token parser)
1940
2031
| Tok_eof -> ()
1941
-
| _ -> failwith "Expected newline after value"
2032
+
| _ ->
2033
+
Error.raise_syntax ~meta:parser.current_meta
2034
+
(Expected "newline after value")
1942
2035
in
1943
2036
1944
2037
parse_document ();
···
2040
2133
(* Convert TOML to tagged JSON for toml-test compatibility *)
2041
2134
let rec toml_to_tagged_json value =
2042
2135
match value with
2043
-
| V.String s ->
2136
+
| V.String (s, _) ->
2044
2137
Fmt.str "{\"type\":\"string\",\"value\":%s}" (json_encode_string s)
2045
-
| V.Int i -> Fmt.str "{\"type\":\"integer\",\"value\":\"%Ld\"}" i
2046
-
| V.Float f ->
2138
+
| V.Int (i, _) -> Fmt.str "{\"type\":\"integer\",\"value\":\"%Ld\"}" i
2139
+
| V.Float (f, _) ->
2047
2140
Fmt.str "{\"type\":\"float\",\"value\":\"%s\"}"
2048
2141
(float_to_tagged_json_str f)
2049
-
| V.Bool b ->
2142
+
| V.Bool (b, _) ->
2050
2143
Fmt.str "{\"type\":\"bool\",\"value\":\"%s\"}"
2051
2144
(if b then "true" else "false")
2052
-
| V.Datetime s ->
2145
+
| V.Datetime (s, _) ->
2053
2146
validate_datetime_string s;
2054
2147
Fmt.str "{\"type\":\"datetime\",\"value\":\"%s\"}" s
2055
-
| V.Datetime_local s ->
2148
+
| V.Datetime_local (s, _) ->
2056
2149
validate_datetime_string s;
2057
2150
Fmt.str "{\"type\":\"datetime-local\",\"value\":\"%s\"}" s
2058
-
| V.Date_local s ->
2151
+
| V.Date_local (s, _) ->
2059
2152
validate_date_string s;
2060
2153
Fmt.str "{\"type\":\"date-local\",\"value\":\"%s\"}" s
2061
-
| V.Time_local s ->
2154
+
| V.Time_local (s, _) ->
2062
2155
validate_time_string s;
2063
2156
Fmt.str "{\"type\":\"time-local\",\"value\":\"%s\"}" s
2064
-
| V.Array items ->
2157
+
| V.Array (items, _) ->
2065
2158
let json_items = List.map toml_to_tagged_json items in
2066
2159
Fmt.str "[%s]" (String.concat "," json_items)
2067
-
| V.Table pairs ->
2160
+
| V.Table (pairs, _) ->
2068
2161
let json_pairs =
2069
2162
List.map
2070
-
(fun (k, v) ->
2163
+
(fun ((k, _), v) ->
2071
2164
Fmt.str "%s:%s" (json_encode_string k) (toml_to_tagged_json v))
2072
2165
pairs
2073
2166
in
···
2094
2187
Buffer.contents buf
2095
2188
2096
2189
let tagged_value_to_toml value =
2190
+
let m = V.Meta.none in
2097
2191
match value with
2098
-
| V.Table [ ("type", V.String typ); ("value", V.String v) ]
2099
-
| V.Table [ ("value", V.String v); ("type", V.String typ) ] -> (
2192
+
| V.Table
2193
+
([ (("type", _), V.String (typ, _)); (("value", _), V.String (v, _)) ], _)
2194
+
| V.Table
2195
+
([ (("value", _), V.String (v, _)); (("type", _), V.String (typ, _)) ], _)
2196
+
-> (
2100
2197
match typ with
2101
-
| "string" -> V.String v
2102
-
| "integer" -> V.Int (Int64.of_string v)
2198
+
| "string" -> V.String (v, m)
2199
+
| "integer" -> V.Int (Int64.of_string v, m)
2103
2200
| "float" -> (
2104
2201
match v with
2105
-
| "inf" -> V.Float Float.infinity
2106
-
| "-inf" -> V.Float Float.neg_infinity
2107
-
| "nan" -> V.Float Float.nan
2108
-
| _ -> V.Float (float_of_string v))
2109
-
| "bool" -> V.Bool (v = "true")
2110
-
| "datetime" -> V.Datetime v
2111
-
| "datetime-local" -> V.Datetime_local v
2112
-
| "date-local" -> V.Date_local v
2113
-
| "time-local" -> V.Time_local v
2202
+
| "inf" -> V.Float (Float.infinity, m)
2203
+
| "-inf" -> V.Float (Float.neg_infinity, m)
2204
+
| "nan" -> V.Float (Float.nan, m)
2205
+
| _ -> V.Float (float_of_string v, m))
2206
+
| "bool" -> V.Bool (v = "true", m)
2207
+
| "datetime" -> V.Datetime (v, m)
2208
+
| "datetime-local" -> V.Datetime_local (v, m)
2209
+
| "date-local" -> V.Date_local (v, m)
2210
+
| "time-local" -> V.Time_local (v, m)
2114
2211
| _ -> Fmt.failwith "Unknown type: %s" typ)
2115
2212
| _ -> value
2116
2213
···
2195
2292
match jr_peek r with
2196
2293
| Some '{' -> jr_read_object r
2197
2294
| Some '[' -> jr_read_array r
2198
-
| Some '"' -> V.String (jr_read_string r)
2295
+
| Some '"' -> V.String (jr_read_string r, V.Meta.none)
2199
2296
| _ -> failwith "Expected value"
2200
2297
2201
2298
and jr_read_object r =
···
2203
2300
jr_skip_ws r;
2204
2301
if jr_peek r = Some '}' then begin
2205
2302
incr r.pos;
2206
-
V.Table []
2303
+
V.Table ([], V.Meta.none)
2207
2304
end
2208
2305
else begin
2209
2306
let pairs = ref [] in
···
2215
2312
let key = jr_read_string r in
2216
2313
jr_expect r ':';
2217
2314
let value = jr_read_value r in
2218
-
pairs := (key, tagged_value_to_toml value) :: !pairs
2315
+
pairs := ((key, V.Meta.none), tagged_value_to_toml value) :: !pairs
2219
2316
done;
2220
2317
jr_expect r '}';
2221
-
V.Table (List.rev !pairs)
2318
+
V.Table (List.rev !pairs, V.Meta.none)
2222
2319
end
2223
2320
2224
2321
and jr_read_array r =
···
2226
2323
jr_skip_ws r;
2227
2324
if jr_peek r = Some ']' then begin
2228
2325
incr r.pos;
2229
-
V.Array []
2326
+
V.Array ([], V.Meta.none)
2230
2327
end
2231
2328
else begin
2232
2329
let items = ref [] in
···
2237
2334
items := tagged_value_to_toml (jr_read_value r) :: !items
2238
2335
done;
2239
2336
jr_expect r ']';
2240
-
V.Array (List.rev !items)
2337
+
V.Array (List.rev !items, V.Meta.none)
2241
2338
end
2242
2339
2243
2340
(* Tagged JSON to TOML for encoder *)
···
2297
2394
2298
2395
and write_toml_value w ?(inline = false) value =
2299
2396
match value with
2300
-
| V.String s -> write_toml_string w s
2301
-
| V.Int i -> Bytes.Writer.write_string w (Int64.to_string i)
2302
-
| V.Float f ->
2397
+
| V.String (s, _) -> write_toml_string w s
2398
+
| V.Int (i, _) -> Bytes.Writer.write_string w (Int64.to_string i)
2399
+
| V.Float (f, _) ->
2303
2400
if Float.is_nan f then Bytes.Writer.write_string w "nan"
2304
2401
else if f = Float.infinity then Bytes.Writer.write_string w "inf"
2305
2402
else if f = Float.neg_infinity then Bytes.Writer.write_string w "-inf"
2306
2403
else begin
2307
2404
let s = Fmt.str "%.17g" f in
2308
-
(* Ensure it looks like a float *)
2309
2405
let s =
2310
2406
if
2311
2407
String.contains s '.' || String.contains s 'e'
···
2315
2411
in
2316
2412
Bytes.Writer.write_string w s
2317
2413
end
2318
-
| V.Bool b -> Bytes.Writer.write_string w (if b then "true" else "false")
2319
-
| V.Datetime s -> Bytes.Writer.write_string w s
2320
-
| V.Datetime_local s -> Bytes.Writer.write_string w s
2321
-
| V.Date_local s -> Bytes.Writer.write_string w s
2322
-
| V.Time_local s -> Bytes.Writer.write_string w s
2323
-
| V.Array items ->
2414
+
| V.Bool (b, _) -> Bytes.Writer.write_string w (if b then "true" else "false")
2415
+
| V.Datetime (s, _) -> Bytes.Writer.write_string w s
2416
+
| V.Datetime_local (s, _) -> Bytes.Writer.write_string w s
2417
+
| V.Date_local (s, _) -> Bytes.Writer.write_string w s
2418
+
| V.Time_local (s, _) -> Bytes.Writer.write_string w s
2419
+
| V.Array (items, _) ->
2324
2420
Bytes.Writer.write_string w "[";
2325
2421
List.iteri
2326
2422
(fun i item ->
···
2328
2424
write_toml_value w ~inline:true item)
2329
2425
items;
2330
2426
Bytes.Writer.write_string w "]"
2331
-
| V.Table pairs when inline ->
2427
+
| V.Table (pairs, _) when inline ->
2332
2428
Bytes.Writer.write_string w "{";
2333
2429
List.iteri
2334
-
(fun i (k, v) ->
2430
+
(fun i ((k, _), v) ->
2335
2431
if i > 0 then Bytes.Writer.write_string w ", ";
2336
2432
write_toml_key w k;
2337
2433
Bytes.Writer.write_string w " = ";
2338
2434
write_toml_value w ~inline:true v)
2339
2435
pairs;
2340
2436
Bytes.Writer.write_string w "}"
2341
-
| V.Table _ -> failwith "Cannot encode table inline without inline flag"
2437
+
| V.Table _ ->
2438
+
Error.raise_encode ~meta:Loc.Meta.none Cannot_encode_inline_table
2342
2439
2343
2440
let is_pure_table_array items =
2344
2441
items <> [] && List.for_all (function V.Table _ -> true | _ -> false) items
···
2352
2449
2353
2450
let rec encode_at_path w has_content path value =
2354
2451
match value with
2355
-
| V.Table pairs ->
2452
+
| V.Table (pairs, _) ->
2356
2453
let simple, nested =
2357
2454
List.partition
2358
2455
(fun (_, v) ->
2359
2456
match v with
2360
2457
| V.Table _ -> false
2361
-
| V.Array items -> not (is_pure_table_array items)
2458
+
| V.Array (items, _) -> not (is_pure_table_array items)
2362
2459
| _ -> true)
2363
2460
pairs
2364
2461
in
2365
2462
List.iter
2366
-
(fun (k, v) ->
2463
+
(fun ((k, _), v) ->
2367
2464
write_toml_key w k;
2368
2465
Bytes.Writer.write_string w " = ";
2369
2466
write_toml_value w ~inline:true v;
···
2371
2468
has_content := true)
2372
2469
simple;
2373
2470
encode_nested_pairs w has_content path nested
2374
-
| _ -> failwith "Top-level TOML must be a table"
2471
+
| _ -> Error.raise_encode ~meta:Loc.Meta.none Not_a_table
2375
2472
2376
2473
and encode_nested_pairs w has_content path nested =
2377
2474
List.iter
2378
-
(fun (k, v) ->
2475
+
(fun ((k, _), v) ->
2379
2476
let new_path = path @ [ k ] in
2380
2477
match v with
2381
2478
| V.Table _ ->
···
2385
2482
Bytes.Writer.write_string w "]\n";
2386
2483
has_content := true;
2387
2484
encode_at_path w has_content new_path v
2388
-
| V.Array items when is_pure_table_array items ->
2485
+
| V.Array (items, _) when is_pure_table_array items ->
2389
2486
encode_table_array w has_content new_path items
2390
2487
| _ ->
2391
2488
write_toml_key w k;
···
2418
2515
Public Interface - Parsing
2419
2516
============================================ *)
2420
2517
2421
-
let of_string input =
2422
-
try Ok (parse_toml input) with
2423
-
| Failure msg -> Error (Error.v (Error.Syntax (Error.Expected msg)))
2424
-
| Error.Error e -> Error e
2425
-
| e -> Error (Error.v (Error.Syntax (Error.Expected (Printexc.to_string e))))
2518
+
let of_string input = try Ok (parse_toml input) with Loc.Error e -> Error e
2426
2519
2427
2520
let of_reader ?file r =
2428
-
try Ok (parse_toml_from_reader ?file r) with
2429
-
| Failure msg -> Error (Error.v (Error.Syntax (Error.Expected msg)))
2430
-
| Error.Error e -> Error e
2431
-
| e -> Error (Error.v (Error.Syntax (Error.Expected (Printexc.to_string e))))
2521
+
try Ok (parse_toml_from_reader ?file r) with Loc.Error e -> Error e
2432
2522
2433
2523
let parse = parse_toml
2434
2524
+4
-7
ocaml-toml/lib/parser.mli
+4
-7
ocaml-toml/lib/parser.mli
···
14
14
15
15
(** {1 Parsing} *)
16
16
17
-
val of_string : string -> (Value.t, Value.Error.t) result
17
+
val of_string : string -> (Value.t, Loc.Error.t) result
18
18
(** [of_string s] parses [s] as a TOML document. *)
19
19
20
-
val of_reader :
21
-
?file:string -> Bytes.Reader.t -> (Value.t, Value.Error.t) result
20
+
val of_reader : ?file:string -> Bytes.Reader.t -> (Value.t, Loc.Error.t) result
22
21
(** [of_reader r] parses a TOML document from reader [r].
23
22
@param file Optional filename for error messages. *)
24
23
···
26
25
(** [parse s] parses [s] as a TOML document.
27
26
@param max_depth caps nesting of arrays and inline tables (default 100).
28
27
@param max_nodes caps total parsed values (default 10_000_000).
29
-
@raise Value.Error.Error on parse errors.
30
-
@raise Loc.Error on depth or node limit exceeded. *)
28
+
@raise Loc.Error on parse errors and depth/node limit violations. *)
31
29
32
30
val parse_reader :
33
31
?file:string -> ?max_depth:int -> ?max_nodes:int -> Bytes.Reader.t -> Value.t
···
35
33
@param file Optional filename for error messages.
36
34
@param max_depth caps nesting of arrays and inline tables (default 100).
37
35
@param max_nodes caps total parsed values (default 10_000_000).
38
-
@raise Value.Error.Error on parse errors.
39
-
@raise Loc.Error on depth or node limit exceeded. *)
36
+
@raise Loc.Error on parse errors and depth/node limit violations. *)
40
37
41
38
(** {1 Encoding} *)
42
39
+77
-78
ocaml-toml/lib/toml.ml
+77
-78
ocaml-toml/lib/toml.ml
···
267
267
module Loc = Loc
268
268
module Meta = Loc.Meta
269
269
module Path = Loc.Path
270
-
module Error = Loc.Error
270
+
module Error = Error
271
271
272
272
exception Error = Loc.Error
273
273
exception Invalid_utf8_encode of int
···
289
289
loop ()
290
290
291
291
let rec validate_utf8_toml : Value.t -> unit = function
292
-
| Value.String s
293
-
| Value.Datetime s
294
-
| Value.Datetime_local s
295
-
| Value.Date_local s
296
-
| Value.Time_local s ->
292
+
| Value.String (s, _)
293
+
| Value.Datetime (s, _)
294
+
| Value.Datetime_local (s, _)
295
+
| Value.Date_local (s, _)
296
+
| Value.Time_local (s, _) ->
297
297
validate_utf8 s
298
-
| Value.Array l -> List.iter validate_utf8_toml l
299
-
| Value.Table kvs ->
298
+
| Value.Array (l, _) -> List.iter validate_utf8_toml l
299
+
| Value.Table (kvs, _) ->
300
300
List.iter
301
-
(fun (k, v) ->
301
+
(fun ((k, _), v) ->
302
302
validate_utf8 k;
303
303
validate_utf8_toml v)
304
304
kvs
···
397
397
doc = "";
398
398
dec =
399
399
(fun lim -> function
400
-
| Value.Bool b ->
400
+
| Value.Bool (b, _) ->
401
401
limits_bump_node lim;
402
402
b
403
403
| v -> err_expected_got "boolean" (type_name v));
404
-
enc = (fun b -> Value.Bool b);
404
+
enc = (fun b -> Value.bool b);
405
405
}
406
406
407
407
let int =
···
410
410
doc = "";
411
411
dec =
412
412
(fun lim -> function
413
-
| Value.Int i ->
413
+
| Value.Int (i, _) ->
414
414
limits_bump_node lim;
415
415
if i >= Int64.of_int min_int && i <= Int64.of_int max_int then
416
416
Int64.to_int i
417
417
else Error.failf Meta.none "integer overflow: %Ld" i
418
418
| v -> err_expected_got "integer" (type_name v));
419
-
enc = (fun i -> Value.Int (Int64.of_int i));
419
+
enc = (fun i -> Value.int_of_int i);
420
420
}
421
421
422
422
let int32 =
···
425
425
doc = "";
426
426
dec =
427
427
(fun lim -> function
428
-
| Value.Int i ->
428
+
| Value.Int (i, _) ->
429
429
limits_bump_node lim;
430
430
if
431
431
i >= Int64.of_int32 Int32.min_int
···
433
433
then Int64.to_int32 i
434
434
else Error.failf Meta.none "integer overflow: %Ld" i
435
435
| v -> err_expected_got "integer" (type_name v));
436
-
enc = (fun i -> Value.Int (Int64.of_int32 i));
436
+
enc = (fun i -> Value.int (Int64.of_int32 i));
437
437
}
438
438
439
439
let int64 =
···
442
442
doc = "";
443
443
dec =
444
444
(fun lim -> function
445
-
| Value.Int i ->
445
+
| Value.Int (i, _) ->
446
446
limits_bump_node lim;
447
447
i
448
448
| v -> err_expected_got "integer" (type_name v));
449
-
enc = (fun i -> Value.Int i);
449
+
enc = (fun i -> Value.int i);
450
450
}
451
451
452
452
let float =
···
455
455
doc = "";
456
456
dec =
457
457
(fun lim -> function
458
-
| Value.Float f ->
458
+
| Value.Float (f, _) ->
459
459
limits_bump_node lim;
460
460
f
461
461
| v -> err_expected_got "float" (type_name v));
462
-
enc = (fun f -> Value.Float f);
462
+
enc = (fun f -> Value.float f);
463
463
}
464
464
465
465
let number =
···
468
468
doc = "";
469
469
dec =
470
470
(fun lim -> function
471
-
| Value.Float f ->
471
+
| Value.Float (f, _) ->
472
472
limits_bump_node lim;
473
473
f
474
-
| Value.Int i ->
474
+
| Value.Int (i, _) ->
475
475
limits_bump_node lim;
476
476
Int64.to_float i
477
477
| v -> err_expected_got "number" (type_name v));
478
-
enc = (fun f -> Value.Float f);
478
+
enc = (fun f -> Value.float f);
479
479
}
480
480
481
481
let string =
···
484
484
doc = "";
485
485
dec =
486
486
(fun lim -> function
487
-
| Value.String s ->
487
+
| Value.String (s, _) ->
488
488
limits_bump_node lim;
489
489
s
490
490
| v -> err_expected_got "string" (type_name v));
491
-
enc = (fun s -> Value.String s);
491
+
enc = (fun s -> Value.string s);
492
492
}
493
493
494
494
let int_as_string =
···
497
497
doc = "";
498
498
dec =
499
499
(fun lim -> function
500
-
| Value.String s -> (
500
+
| Value.String (s, _) -> (
501
501
limits_bump_node lim;
502
502
match int_of_string_opt s with
503
503
| Some i -> i
504
504
| None -> Error.failf Meta.none "cannot parse integer: %s" s)
505
505
| v -> err_expected_got "string" (type_name v));
506
-
enc = (fun i -> Value.String (Int.to_string i));
506
+
enc = (fun i -> Value.string (Int.to_string i));
507
507
}
508
508
509
509
let int64_as_string =
···
512
512
doc = "";
513
513
dec =
514
514
(fun lim -> function
515
-
| Value.String s -> (
515
+
| Value.String (s, _) -> (
516
516
limits_bump_node lim;
517
517
match Int64.of_string_opt s with
518
518
| Some i -> i
519
519
| None -> Error.failf Meta.none "cannot parse int64: %s" s)
520
520
| v -> err_expected_got "string" (type_name v));
521
-
enc = (fun i -> Value.String (Int64.to_string i));
521
+
enc = (fun i -> Value.string (Int64.to_string i));
522
522
}
523
523
524
524
(* ---- Ptime codecs ---- *)
···
635
635
let m = total_secs mod 3600 / 60 in
636
636
let s = total_secs mod 60 in
637
637
if frac > 0.0 then
638
-
Value.Time_local
638
+
Value.time_local
639
639
(Fmt.str "%02d:%02d:%02d%s" h m s
640
640
(String.sub (Fmt.str "%.9f" frac) 1 10))
641
-
else Value.Time_local (Fmt.str "%02d:%02d:%02d" h m s));
641
+
else Value.time_local (Fmt.str "%02d:%02d:%02d" h m s));
642
642
}
643
643
644
644
let ptime_date =
···
656
656
| v -> err_expected_got "date-local" (type_name v));
657
657
enc =
658
658
(fun (year, month, day) ->
659
-
Value.Date_local (Fmt.str "%04d-%02d-%02d" year month day));
659
+
Value.date_local (Fmt.str "%04d-%02d-%02d" year month day));
660
660
}
661
661
662
662
let ptime_full ?tz_offset_s ?get_tz () =
···
709
709
(fun lim _ ->
710
710
limits_bump_node lim;
711
711
v);
712
-
enc = (fun _ -> Value.Table []);
712
+
enc = (fun _ -> Value.table []);
713
713
}
714
714
715
715
let enum ?cmp ?kind ?doc assoc =
···
722
722
doc;
723
723
dec =
724
724
(fun lim -> function
725
-
| Value.String s -> (
725
+
| Value.String (s, _) -> (
726
726
limits_bump_node lim;
727
727
match List.assoc_opt s assoc with
728
728
| Some v -> v
···
731
731
enc =
732
732
(fun v ->
733
733
match List.find_opt (fun (v', _) -> cmp v v' = 0) rev_assoc with
734
-
| Some (_, s) -> Value.String s
734
+
| Some (_, s) -> Value.string s
735
735
| None -> failwith "enum value not in association list");
736
736
}
737
737
···
742
742
kind;
743
743
doc;
744
744
dec = (fun lim v -> Some (c.dec lim v));
745
-
enc = (function Some v -> c.enc v | None -> Value.Table []);
745
+
enc = (function Some v -> c.enc v | None -> Value.table []);
746
746
}
747
747
748
748
let result ~ok ~error =
···
790
790
791
791
(* ---- Query combinators ---- *)
792
792
793
+
(* Lookup a key in a TOML table's pairs list (keys are [name = string node]). *)
794
+
let assoc_name_opt name pairs =
795
+
List.find_map (fun ((k, _), v) -> if k = name then Some v else None) pairs
796
+
793
797
let key name value_codec =
794
798
let tkn = table_kind_node "" in
795
799
{
···
797
801
doc = "";
798
802
dec =
799
803
(fun lim -> function
800
-
| Value.Table pairs -> (
804
+
| Value.Table (pairs, _) -> (
801
805
limits_bump_node lim;
802
-
match List.assoc_opt name pairs with
806
+
match assoc_name_opt name pairs with
803
807
| Some v ->
804
808
push_mem_ctx tkn (name, Meta.none) (fun () ->
805
809
value_codec.dec lim v)
806
810
| None -> Error.failf Meta.none "missing member %S" name)
807
811
| v -> err_expected_got "table" (type_name v));
808
-
enc = (fun x -> Value.Table [ (name, value_codec.enc x) ]);
812
+
enc = (fun x -> Value.table [ (name, value_codec.enc x) ]);
809
813
}
810
814
811
815
(* ---- Update combinators ---- *)
···
817
821
doc = "";
818
822
dec =
819
823
(fun lim -> function
820
-
| Value.Table pairs -> (
824
+
| Value.Table (pairs, m) -> (
821
825
limits_bump_node lim;
822
-
match List.assoc_opt name pairs with
826
+
match assoc_name_opt name pairs with
823
827
| Some v ->
824
828
let decoded =
825
829
push_mem_ctx tkn (name, Meta.none) (fun () -> c.dec lim v)
···
827
831
let encoded = c.enc decoded in
828
832
let pairs' =
829
833
List.map
830
-
(fun (k, vv) -> if k = name then (k, encoded) else (k, vv))
834
+
(fun ((k, km), vv) ->
835
+
if k = name then ((k, km), encoded) else ((k, km), vv))
831
836
pairs
832
837
in
833
-
Value.Table pairs'
838
+
Value.Table (pairs', m)
834
839
| None -> Error.failf Meta.none "missing member %S" name)
835
840
| v -> err_expected_got "table" (type_name v));
836
841
enc = Fun.id;
···
842
847
doc = "";
843
848
dec =
844
849
(fun lim -> function
845
-
| Value.Table pairs ->
850
+
| Value.Table (pairs, m) ->
846
851
limits_bump_node lim;
847
-
let pairs' = List.filter (fun (k, _) -> k <> name) pairs in
848
-
Value.Table pairs'
852
+
let pairs' = List.filter (fun ((k, _), _) -> k <> name) pairs in
853
+
Value.Table (pairs', m)
849
854
| v -> err_expected_got "table" (type_name v));
850
855
enc = Fun.id;
851
856
}
···
857
862
doc = "";
858
863
dec =
859
864
(fun lim -> function
860
-
| Value.Array arr -> (
865
+
| Value.Array (arr, _) -> (
861
866
limits_bump_node lim;
862
867
if n >= 0 && n < List.length arr then
863
868
push_nth_ctx akn (n, Meta.none) (fun () ->
···
867
872
| Some v -> v
868
873
| None -> Error.failf Meta.none "array index %d out of bounds" n)
869
874
| v -> err_expected_got "array" (type_name v));
870
-
enc = (fun x -> Value.Array [ elt_codec.enc x ]);
875
+
enc = (fun x -> Value.array [ elt_codec.enc x ]);
871
876
}
872
877
873
878
let mem ?absent name value_codec =
···
877
882
doc = "";
878
883
dec =
879
884
(fun lim -> function
880
-
| Value.Table pairs -> (
885
+
| Value.Table (pairs, _) -> (
881
886
limits_bump_node lim;
882
-
match List.assoc_opt name pairs with
887
+
match assoc_name_opt name pairs with
883
888
| Some v ->
884
889
push_mem_ctx tkn (name, Meta.none) (fun () ->
885
890
value_codec.dec lim v)
···
888
893
| Some v -> v
889
894
| None -> Error.failf Meta.none "missing member %S" name))
890
895
| v -> err_expected_got "table" (type_name v));
891
-
enc = (fun x -> Value.Table [ (name, value_codec.enc x) ]);
896
+
enc = (fun x -> Value.table [ (name, value_codec.enc x) ]);
892
897
}
893
898
894
899
let fold_array elt_codec f init =
···
898
903
doc = "";
899
904
dec =
900
905
(fun lim -> function
901
-
| Value.Array arr ->
906
+
| Value.Array (arr, _) ->
902
907
limits_bump_node lim;
903
908
let rec loop acc i = function
904
909
| [] -> acc
···
911
916
in
912
917
loop init 0 arr
913
918
| v -> err_expected_got "array" (type_name v));
914
-
enc = (fun _ -> Value.Array []);
919
+
enc = (fun _ -> Value.array []);
915
920
}
916
921
917
922
let fold_table value_codec f init =
···
921
926
doc = "";
922
927
dec =
923
928
(fun lim -> function
924
-
| Value.Table pairs ->
929
+
| Value.Table (pairs, _) ->
925
930
limits_bump_node lim;
926
931
let rec loop acc = function
927
932
| [] -> acc
928
-
| (k, v) :: rest ->
933
+
| ((k, _), v) :: rest ->
929
934
let x =
930
935
push_mem_ctx tkn (k, Meta.none) (fun () ->
931
936
value_codec.dec lim v)
···
934
939
in
935
940
loop init pairs
936
941
| v -> err_expected_got "table" (type_name v));
937
-
enc = (fun _ -> Value.Table []);
942
+
enc = (fun _ -> Value.table []);
938
943
}
939
944
940
945
(* ---- Ignoring and placeholders ---- *)
···
952
957
kind = "zero";
953
958
doc = "";
954
959
dec = (fun lim _ -> limits_bump_node lim);
955
-
enc = (fun () -> Value.Table []);
960
+
enc = (fun () -> Value.table []);
956
961
}
957
962
958
963
let todo ?kind ?doc ?dec_stub () =
···
1030
1035
doc = m.doc;
1031
1036
dec =
1032
1037
(fun lim -> function
1033
-
| Value.Array items ->
1038
+
| Value.Array (items, _) ->
1034
1039
limits_bump_node lim;
1035
1040
limits_enter lim;
1036
1041
let rec decode_items builder i = function
···
1049
1054
enc =
1050
1055
(fun arr ->
1051
1056
let items = m.enc.fold (fun acc elt -> m.elt.enc elt :: acc) [] arr in
1052
-
Value.Array (List.rev items));
1057
+
Value.array (List.rev items));
1053
1058
}
1054
1059
end
1055
1060
···
1303
1308
{
1304
1309
kind = "unknown";
1305
1310
doc = "";
1306
-
dec = (fun _ _ -> Value.Table []);
1307
-
enc = (fun _ -> Value.Table []);
1311
+
dec = (fun _ _ -> Value.table []);
1312
+
enc = (fun _ -> Value.table []);
1308
1313
};
1309
-
dec_absent = Some (Value.Table []);
1314
+
dec_absent = Some (Value.table []);
1310
1315
enc_typed = None;
1311
1316
}
1312
1317
in
···
1360
1365
doc = m.map_doc;
1361
1366
dec =
1362
1367
(fun lim -> function
1363
-
| Value.Table pairs ->
1368
+
| Value.Table (pairs, _) ->
1364
1369
limits_bump_node lim;
1365
1370
limits_enter lim;
1371
+
let plain_pairs = List.map (fun ((k, _), v) -> (k, v)) pairs in
1366
1372
(* Handle unknown members (check/collect) before running the
1367
1373
dec chain. *)
1368
1374
(match m.unknown with
···
1373
1379
if not (List.mem name known_names) then
1374
1380
push_mem_ctx tkn (name, Meta.none) (fun () ->
1375
1381
Error.failf Meta.none "unknown member: %s" name))
1376
-
pairs
1382
+
plain_pairs
1377
1383
| Keep collector ->
1378
1384
List.iter
1379
1385
(fun (name, v) ->
1380
1386
if not (List.mem name known_names) then collector name v)
1381
-
pairs);
1382
-
let result = m.dec lim pairs in
1387
+
plain_pairs);
1388
+
let result = m.dec lim plain_pairs in
1383
1389
limits_leave lim;
1384
1390
result
1385
1391
| v -> err_expected_got "table" (type_name v));
···
1402
1408
| None -> pairs
1403
1409
| Some get_unknown -> pairs @ get_unknown o
1404
1410
in
1405
-
Value.Table pairs);
1411
+
Value.table pairs);
1406
1412
}
1407
1413
1408
1414
let finish m = finish_common ~inline:false m
···
1420
1426
doc;
1421
1427
dec =
1422
1428
(fun lim -> function
1423
-
| Value.Array items ->
1429
+
| Value.Array (items, _) ->
1424
1430
limits_bump_node lim;
1425
1431
limits_enter lim;
1426
1432
let rec decode_items acc i = function
···
1435
1441
limits_leave lim;
1436
1442
result
1437
1443
| v -> err_expected_got "array" (type_name v));
1438
-
enc = (fun xs -> Value.Array (List.map c.enc xs));
1444
+
enc = (fun xs -> Value.array (List.map c.enc xs));
1439
1445
}
1440
1446
1441
1447
(* ---- Any / Generic value codecs ---- *)
···
1457
1463
doc = "";
1458
1464
dec =
1459
1465
(fun lim -> function
1460
-
| Value.Table pairs ->
1466
+
| Value.Table (pairs, _) ->
1461
1467
limits_bump_node lim;
1462
-
pairs
1468
+
List.map (fun ((k, _), v) -> (k, v)) pairs
1463
1469
| v -> err_expected_got "table" (type_name v));
1464
-
enc = (fun pairs -> Value.Table pairs);
1470
+
enc = (fun pairs -> Value.table pairs);
1465
1471
}
1466
1472
1467
1473
let any ?kind ?doc ?dec_string ?dec_int ?dec_float ?dec_bool ?dec_datetime
···
1525
1531
Delegates parsing and encoding to [Parser], which lives in the same
1526
1532
library. *)
1527
1533
1528
-
(* Translate a Value.Error.t (from the TOML parser) into a Loc.Error.t
1529
-
so the public decode boundary speaks a single error vocabulary. *)
1530
-
let error_to_loc (e : Value.Error.t) : Error.t =
1531
-
Error.msg ~ctx:Loc.Context.empty ~meta:Meta.none (Value.Error.to_string e)
1532
-
1533
1534
let of_string ?max_depth ?max_nodes c s =
1534
1535
try
1535
1536
let toml = Parser.parse ?max_depth ?max_nodes s in
1536
1537
Ok (of_toml_raise ?max_depth ?max_nodes c toml)
1537
1538
with
1538
1539
| Loc.Error e -> Error e
1539
-
| Value.Error.Error e -> Error (error_to_loc e)
1540
1540
| Failure msg -> Error (Error.msg ~ctx:Loc.Context.empty ~meta:Meta.none msg)
1541
1541
1542
1542
let of_string_exn ?max_depth ?max_nodes c s =
···
1550
1550
Ok (of_toml_raise ?max_depth ?max_nodes c toml)
1551
1551
with
1552
1552
| Loc.Error e -> Error e
1553
-
| Value.Error.Error e -> Error (error_to_loc e)
1554
1553
| Failure msg -> Error (Error.msg ~ctx:Loc.Context.empty ~meta:Meta.none msg)
1555
1554
1556
1555
let of_reader_exn ?max_depth ?max_nodes c reader =
+9
-2
ocaml-toml/lib/toml.mli
+9
-2
ocaml-toml/lib/toml.mli
···
91
91
module Loc = Loc
92
92
module Meta = Loc.Meta
93
93
module Path = Loc.Path
94
-
module Error = Loc.Error
94
+
95
+
module Error = Error
96
+
(** TOML error facade.
97
+
98
+
Extends {!Loc.Error.kind} with TOML-specific typed kinds ({!Error.Lexer},
99
+
{!Error.Number}, {!Error.Datetime}, {!Error.Semantic}, {!Error.Syntax},
100
+
{!Error.Encode}) and exports the shared {!Loc.Error} verbs. *)
95
101
96
102
exception Error of Error.t
97
-
(** Raised by decoders. *)
103
+
(** Raised by decoders on structured errors. Alias of {!Loc.Error.Error}:
104
+
[match exn with Toml.Error _ | Loc.Error _ -> ...] are equivalent. *)
98
105
99
106
exception Invalid_utf8_encode of int
100
107
(** Raised by the encoder when asked to write an OCaml string that contains
+2
-2
ocaml-toml/lib/unix/toml_unix.mli
+2
-2
ocaml-toml/lib/unix/toml_unix.mli
···
58
58
val of_channel : ?file:string -> in_channel -> Toml.Value.t
59
59
(** [of_channel ic] reads and parses TOML from an input channel.
60
60
@param file Optional filename for error messages.
61
-
@raise Toml.Value.Error.exception-Error on parse errors. *)
61
+
@raise Loc.Error on parse errors. *)
62
62
63
63
val to_channel : out_channel -> Toml.Value.t -> unit
64
64
(** [to_channel oc value] writes [value] as TOML to an output channel.
···
74
74
75
75
val decode_file_exn : 'a Toml.t -> string -> 'a
76
76
(** [decode_file_exn codec path] is like {!decode_file} but raises on errors.
77
-
@raise Toml.Value.Error.exception-Error on parse or decode errors.
77
+
@raise Loc.Error on parse or decode errors.
78
78
@raise Sys_error on file errors. *)
79
79
80
80
val encode_file : 'a Toml.t -> 'a -> string -> unit
+165
-129
ocaml-toml/lib/value.ml
+165
-129
ocaml-toml/lib/value.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(* TOML value representation *)
6
+
(* TOML value representation. Every constructor carries a [Loc.Meta.t]
7
+
via the [node] wrapper: parsers fill it with source positions and
8
+
surrounding whitespace; programmatic constructors default it to
9
+
[Loc.Meta.none]. *)
10
+
11
+
module Meta = Loc.Meta
12
+
13
+
type 'a node = 'a Loc.node
14
+
type name = string node
7
15
8
16
type t =
9
-
| String of string
10
-
| Int of int64
11
-
| Float of float
12
-
| Bool of bool
13
-
| Datetime of string (* Offset datetime *)
14
-
| Datetime_local of string (* Local datetime *)
15
-
| Date_local of string (* Local date *)
16
-
| Time_local of string (* Local time *)
17
-
| Array of t list
18
-
| Table of (string * t) list
17
+
| String of string node
18
+
| Int of int64 node
19
+
| Float of float node
20
+
| Bool of bool node
21
+
| Datetime of string node (* Offset datetime *)
22
+
| Datetime_local of string node (* Local datetime *)
23
+
| Date_local of string node (* Local date *)
24
+
| Time_local of string node (* Local time *)
25
+
| Array of t list node
26
+
| Table of (name * t) list node
27
+
28
+
(* Inner helpers shared by constructors and accessors. *)
29
+
let n ?(meta = Meta.none) v = (v, meta)
19
30
20
31
(* ============================================
21
32
Value Constructors
22
33
============================================ *)
23
34
24
-
let string s = String s
25
-
let int i = Int i
26
-
let int_of_int i = Int (Int64.of_int i)
27
-
let float f = Float f
28
-
let bool b = Bool b
29
-
let array vs = Array vs
30
-
let table pairs = Table pairs
31
-
let datetime s = Datetime s
32
-
let datetime_local s = Datetime_local s
33
-
let date_local s = Date_local s
34
-
let time_local s = Time_local s
35
+
let string ?meta s = String (n ?meta s)
36
+
let int ?meta i = Int (n ?meta i)
37
+
let int_of_int ?meta i = Int (n ?meta (Int64.of_int i))
38
+
let float ?meta f = Float (n ?meta f)
39
+
let bool ?meta b = Bool (n ?meta b)
40
+
let array ?meta vs = Array (n ?meta vs)
41
+
42
+
let table ?meta pairs =
43
+
Table (n ?meta (List.map (fun (k, v) -> (n k, v)) pairs))
44
+
45
+
let datetime ?meta s = Datetime (n ?meta s)
46
+
let datetime_local ?meta s = Datetime_local (n ?meta s)
47
+
let date_local ?meta s = Date_local (n ?meta s)
48
+
let time_local ?meta s = Time_local (n ?meta s)
49
+
50
+
(* ============================================
51
+
Metadata accessors
52
+
============================================ *)
53
+
54
+
let meta = function
55
+
| String (_, m)
56
+
| Int (_, m)
57
+
| Float (_, m)
58
+
| Bool (_, m)
59
+
| Datetime (_, m)
60
+
| Datetime_local (_, m)
61
+
| Date_local (_, m)
62
+
| Time_local (_, m)
63
+
| Array (_, m)
64
+
| Table (_, m) ->
65
+
m
35
66
36
67
(* ============================================
37
68
Ptime Conversions
38
69
============================================ *)
39
70
40
71
let datetime_of_ptime ?(tz_offset_s = 0) ?(frac_s = 0) ptime =
41
-
Datetime (Ptime.to_rfc3339 ~tz_offset_s ~frac_s ptime)
72
+
datetime (Ptime.to_rfc3339 ~tz_offset_s ~frac_s ptime)
42
73
43
74
let date_of_ptime ?(tz_offset_s = 0) ptime =
44
75
let year, month, day = Ptime.to_date ~tz_offset_s ptime in
45
-
Date_local (Fmt.str "%04d-%02d-%02d" year month day)
76
+
date_local (Fmt.str "%04d-%02d-%02d" year month day)
46
77
47
78
(* Helper to normalize TOML datetime for ptime parsing.
48
79
TOML 1.1 allows optional seconds (e.g., "1979-05-27T07:32Z"),
···
51
82
let len = String.length s in
52
83
if len < 16 then s (* Too short, let ptime handle the error *)
53
84
else
54
-
(* Check if we have HH:MM followed by timezone or end without seconds *)
55
-
(* Format: YYYY-MM-DDTHH:MM... position 16 would be after HH:MM *)
56
85
let has_t = len > 10 && (s.[10] = 'T' || s.[10] = 't' || s.[10] = ' ') in
57
86
if not has_t then s
58
87
else if len >= 17 && s.[16] = ':' then s (* Already has seconds *)
59
-
else if len = 16 then
60
-
(* YYYY-MM-DDTHH:MM - local datetime without seconds, add :00 *)
61
-
s ^ ":00"
88
+
else if len = 16 then s ^ ":00"
62
89
else
63
90
let c16 = s.[16] in
64
91
if c16 = 'Z' || c16 = 'z' || c16 = '+' || c16 = '-' then
65
-
(* YYYY-MM-DDTHH:MMZ or YYYY-MM-DDTHH:MM+... - insert :00 before tz *)
66
92
String.sub s 0 16 ^ ":00" ^ String.sub s 16 (len - 16)
67
-
else if c16 = '.' then
68
-
(* YYYY-MM-DDTHH:MM.fraction - unusual but handle it *)
69
-
s
93
+
else if c16 = '.' then s
70
94
else s
71
95
72
96
let to_ptime_tz = function
73
-
| Datetime s -> (
97
+
| Datetime (s, _) -> (
74
98
let normalized = normalize_datetime_for_ptime s in
75
99
match Ptime.of_rfc3339 ~strict:false normalized with
76
100
| Ok (t, tz, _) -> Some (t, tz)
···
78
102
| _ -> None
79
103
80
104
let to_ptime_opt = function
81
-
| Datetime s -> (
105
+
| Datetime (s, _) -> (
82
106
let normalized = normalize_datetime_for_ptime s in
83
107
match Ptime.of_rfc3339 ~strict:false normalized with
84
108
| Ok (t, _, _) -> Some t
···
100
124
| _ -> invalid_arg "Toml.to_ptime: not a datetime")
101
125
102
126
let to_date_opt = function
103
-
| Date_local s when String.length s >= 10 -> (
127
+
| Date_local (s, _) when String.length s >= 10 -> (
104
128
try
105
129
let year = int_of_string (String.sub s 0 4) in
106
130
let month = int_of_string (String.sub s 5 2) in
107
131
let day = int_of_string (String.sub s 8 2) in
108
-
(* Validate using Ptime.of_date *)
109
132
match Ptime.of_date (year, month, day) with
110
133
| Some _ -> Some (year, month, day)
111
134
| None -> None
···
131
154
(* Parse local datetime string to ptime using given timezone offset *)
132
155
let parse_local_datetime_with_tz tz_offset_s s =
133
156
let normalized = normalize_datetime_for_ptime s in
134
-
(* Append timezone to make it parseable by ptime *)
135
157
let tz_str =
136
158
if tz_offset_s = 0 then "Z"
137
159
else
···
160
182
let frac =
161
183
if len > 9 && s.[8] = '.' then
162
184
let frac_str = String.sub s 9 (len - 9) in
163
-
(* Pad or truncate to 9 digits for nanoseconds *)
164
185
let padded =
165
186
if String.length frac_str >= 9 then String.sub frac_str 0 9
166
187
else frac_str ^ String.make (9 - String.length frac_str) '0'
···
169
190
else 0
170
191
in
171
192
(sec, frac)
172
-
else
173
-
(* TOML 1.1: optional seconds *)
174
-
(0, 0)
193
+
else (0, 0)
175
194
in
176
195
if
177
196
hour >= 0 && hour <= 23 && minute >= 0 && minute <= 59 && second >= 0
178
197
&& second <= 60
179
-
then
180
-
(* 60 for leap second *)
181
-
Some (hour, minute, second, frac)
198
+
then Some (hour, minute, second, frac)
182
199
else None
183
200
with Failure _ -> None
184
201
185
202
let to_ptime_datetime ?tz_offset_s t =
186
-
let get_tz () =
187
-
match tz_offset_s with
188
-
| Some tz -> tz
189
-
| None -> 0 (* Default to UTC when no timezone provided *)
190
-
in
203
+
let get_tz () = match tz_offset_s with Some tz -> tz | None -> 0 in
191
204
match t with
192
-
| Datetime s -> (
205
+
| Datetime (s, _) -> (
193
206
let normalized = normalize_datetime_for_ptime s in
194
207
match Ptime.of_rfc3339 ~strict:false normalized with
195
208
| Ok (ptime, tz, _) -> Some (`Datetime (ptime, tz))
196
209
| Error _ -> None)
197
-
| Datetime_local s -> (
210
+
| Datetime_local (s, _) -> (
198
211
let tz = get_tz () in
199
212
match parse_local_datetime_with_tz tz s with
200
213
| Some ptime -> Some (`Datetime_local ptime)
201
214
| None -> None)
202
215
| Date_local _ -> (
203
216
match to_date_opt t with Some date -> Some (`Date date) | None -> None)
204
-
| Time_local s -> (
217
+
| Time_local (s, _) -> (
205
218
match parse_local_time s with
206
219
| Some time -> Some (`Time time)
207
220
| None -> None)
···
210
223
let ptime_datetime_to_toml = function
211
224
| `Datetime (ptime, tz) ->
212
225
let tz_offset_s = Option.value ~default:0 tz in
213
-
Datetime (Ptime.to_rfc3339 ~tz_offset_s ptime)
226
+
datetime (Ptime.to_rfc3339 ~tz_offset_s ptime)
214
227
| `Datetime_local ptime ->
215
-
(* Convert to local time string without timezone *)
216
228
let (year, month, day), ((hour, minute, second), _) =
217
229
Ptime.to_date_time ptime
218
230
in
219
-
Datetime_local
231
+
datetime_local
220
232
(Fmt.str "%04d-%02d-%02dT%02d:%02d:%02d" year month day hour minute
221
233
second)
222
234
| `Date (year, month, day) ->
223
-
Date_local (Fmt.str "%04d-%02d-%02d" year month day)
235
+
date_local (Fmt.str "%04d-%02d-%02d" year month day)
224
236
| `Time (hour, minute, second, ns) ->
225
-
if ns = 0 then Time_local (Fmt.str "%02d:%02d:%02d" hour minute second)
237
+
if ns = 0 then time_local (Fmt.str "%02d:%02d:%02d" hour minute second)
226
238
else
227
-
(* Format nanoseconds, trimming trailing zeros *)
228
239
let ns_str = Fmt.str "%09d" ns in
229
240
let rec trim_end i =
230
241
if i <= 0 then 1
···
232
243
else trim_end (i - 1)
233
244
in
234
245
let ns_trimmed = String.sub ns_str 0 (trim_end 8) in
235
-
Time_local (Fmt.str "%02d:%02d:%02d.%s" hour minute second ns_trimmed)
246
+
time_local (Fmt.str "%02d:%02d:%02d.%s" hour minute second ns_trimmed)
236
247
237
248
let pp_ptime_datetime fmt = function
238
249
| `Datetime (ptime, tz) ->
···
250
261
============================================ *)
251
262
252
263
let to_string = function
253
-
| String s -> s
264
+
| String (s, _) -> s
254
265
| _ -> invalid_arg "Toml.to_string: not a string"
255
266
256
-
let to_string_opt = function String s -> Some s | _ -> None
267
+
let to_string_opt = function String (s, _) -> Some s | _ -> None
257
268
258
269
let to_int = function
259
-
| Int i -> i
270
+
| Int (i, _) -> i
260
271
| _ -> invalid_arg "Toml.to_int: not an integer"
261
272
262
-
let to_int_opt = function Int i -> Some i | _ -> None
273
+
let to_int_opt = function Int (i, _) -> Some i | _ -> None
263
274
264
275
let to_float = function
265
-
| Float f -> f
276
+
| Float (f, _) -> f
266
277
| _ -> invalid_arg "Toml.to_float: not a float"
267
278
268
-
let to_float_opt = function Float f -> Some f | _ -> None
279
+
let to_float_opt = function Float (f, _) -> Some f | _ -> None
269
280
270
281
let to_bool = function
271
-
| Bool b -> b
282
+
| Bool (b, _) -> b
272
283
| _ -> invalid_arg "Toml.to_bool: not a boolean"
273
284
274
-
let to_bool_opt = function Bool b -> Some b | _ -> None
285
+
let to_bool_opt = function Bool (b, _) -> Some b | _ -> None
275
286
276
287
let to_array = function
277
-
| Array vs -> vs
288
+
| Array (vs, _) -> vs
278
289
| _ -> invalid_arg "Toml.to_array: not an array"
279
290
280
-
let to_array_opt = function Array vs -> Some vs | _ -> None
291
+
let to_array_opt = function Array (vs, _) -> Some vs | _ -> None
281
292
282
293
let to_table = function
283
-
| Table pairs -> pairs
294
+
| Table (pairs, _) -> List.map (fun ((k, _), v) -> (k, v)) pairs
284
295
| _ -> invalid_arg "Toml.to_table: not a table"
285
296
286
-
let to_table_opt = function Table pairs -> Some pairs | _ -> None
297
+
let to_table_opt = function
298
+
| Table (pairs, _) -> Some (List.map (fun ((k, _), v) -> (k, v)) pairs)
299
+
| _ -> None
287
300
288
301
let to_datetime = function
289
-
| Datetime s | Datetime_local s | Date_local s | Time_local s -> s
302
+
| Datetime (s, _)
303
+
| Datetime_local (s, _)
304
+
| Date_local (s, _)
305
+
| Time_local (s, _) ->
306
+
s
290
307
| _ -> invalid_arg "Toml.to_datetime: not a datetime"
291
308
292
309
let to_datetime_opt = function
293
-
| Datetime s | Datetime_local s | Date_local s | Time_local s -> Some s
310
+
| Datetime (s, _)
311
+
| Datetime_local (s, _)
312
+
| Date_local (s, _)
313
+
| Time_local (s, _) ->
314
+
Some s
294
315
| _ -> None
295
316
296
317
(* ============================================
···
312
333
Table Navigation
313
334
============================================ *)
314
335
336
+
let rec assoc_name k = function
337
+
| [] -> raise Not_found
338
+
| ((k', _), v) :: rest -> if k = k' then v else assoc_name k rest
339
+
340
+
let rec assoc_opt_name k = function
341
+
| [] -> None
342
+
| ((k', _), v) :: rest -> if k = k' then Some v else assoc_opt_name k rest
343
+
344
+
let rec mem_name k = function
345
+
| [] -> false
346
+
| ((k', _), _) :: rest -> if k = k' then true else mem_name k rest
347
+
315
348
let get key = function
316
-
| Table pairs -> List.assoc key pairs
349
+
| Table (pairs, _) -> assoc_name key pairs
317
350
| _ -> invalid_arg "Toml.get: not a table"
318
351
319
-
let opt key = function Table pairs -> List.assoc_opt key pairs | _ -> None
320
-
let mem key = function Table pairs -> List.mem_assoc key pairs | _ -> false
352
+
let opt key = function
353
+
| Table (pairs, _) -> assoc_opt_name key pairs
354
+
| _ -> None
355
+
356
+
let mem key = function Table (pairs, _) -> mem_name key pairs | _ -> false
321
357
322
358
let keys = function
323
-
| Table pairs -> List.map fst pairs
359
+
| Table (pairs, _) -> List.map (fun ((k, _), _) -> k) pairs
324
360
| _ -> invalid_arg "Toml.keys: not a table"
325
361
326
362
let rec path path_keys t =
···
328
364
| [] -> t
329
365
| key :: rest -> (
330
366
match t with
331
-
| Table pairs -> (
332
-
match List.assoc_opt key pairs with
367
+
| Table (pairs, _) -> (
368
+
match assoc_opt_name key pairs with
333
369
| Some v -> path rest v
334
370
| None -> raise Not_found)
335
371
| _ -> invalid_arg "Toml.path: intermediate value is not a table")
···
339
375
340
376
let ( .%{} ) t path_keys = path path_keys t
341
377
342
-
let rec set_at_path path v t =
343
-
match path with
378
+
let rec set_at_path p v t =
379
+
match p with
344
380
| [] -> v
345
381
| [ key ] -> (
346
382
match t with
347
-
| Table pairs ->
348
-
let pairs' = List.filter (fun (k, _) -> k <> key) pairs in
349
-
Table ((key, v) :: pairs')
383
+
| Table (pairs, m) ->
384
+
let pairs' = List.filter (fun ((k, _), _) -> k <> key) pairs in
385
+
Table ((n key, v) :: pairs', m)
350
386
| _ -> invalid_arg "Toml.(.%{}<-): not a table")
351
387
| key :: rest -> (
352
388
match t with
353
-
| Table pairs ->
354
-
let existing = List.assoc_opt key pairs in
389
+
| Table (pairs, m) ->
390
+
let existing = assoc_opt_name key pairs in
355
391
let subtable =
356
392
match existing with
357
393
| Some (Table _ as sub) -> sub
358
394
| Some _ ->
359
395
invalid_arg "Toml.(.%{}<-): intermediate value is not a table"
360
-
| None -> Table []
396
+
| None -> Table ([], Meta.none)
361
397
in
362
398
let updated = set_at_path rest v subtable in
363
-
let pairs' = List.filter (fun (k, _) -> k <> key) pairs in
364
-
Table ((key, updated) :: pairs')
399
+
let pairs' = List.filter (fun ((k, _), _) -> k <> key) pairs in
400
+
Table ((n key, updated) :: pairs', m)
365
401
| _ -> invalid_arg "Toml.(.%{}<-): not a table")
366
402
367
-
let ( .%{}<- ) t path v = set_at_path path v t
403
+
let ( .%{}<- ) t p v = set_at_path p v t
368
404
369
405
(* ============================================
370
406
Pretty Printing
371
407
============================================ *)
372
408
373
409
let rec pp_value fmt = function
374
-
| String s -> Fmt.pf fmt "\"%s\"" (String.escaped s)
375
-
| Int i -> Fmt.pf fmt "%Ld" i
376
-
| Float f ->
410
+
| String (s, _) -> Fmt.pf fmt "\"%s\"" (String.escaped s)
411
+
| Int (i, _) -> Fmt.pf fmt "%Ld" i
412
+
| Float (f, _) ->
377
413
if Float.is_nan f then Fmt.pf fmt "nan"
378
414
else if f = Float.infinity then Fmt.pf fmt "inf"
379
415
else if f = Float.neg_infinity then Fmt.pf fmt "-inf"
380
416
else Fmt.pf fmt "%g" f
381
-
| Bool b -> Fmt.pf fmt "%s" (if b then "true" else "false")
382
-
| Datetime s | Datetime_local s | Date_local s | Time_local s ->
417
+
| Bool (b, _) -> Fmt.pf fmt "%s" (if b then "true" else "false")
418
+
| Datetime (s, _)
419
+
| Datetime_local (s, _)
420
+
| Date_local (s, _)
421
+
| Time_local (s, _) ->
383
422
Fmt.pf fmt "%s" s
384
-
| Array items ->
423
+
| Array (items, _) ->
385
424
Fmt.pf fmt "[";
386
425
List.iteri
387
426
(fun i item ->
···
389
428
pp_value fmt item)
390
429
items;
391
430
Fmt.pf fmt "]"
392
-
| Table pairs ->
431
+
| Table (pairs, _) ->
393
432
Fmt.pf fmt "{";
394
433
List.iteri
395
-
(fun i (k, v) ->
434
+
(fun i ((k, _), v) ->
396
435
if i > 0 then Fmt.pf fmt ", ";
397
436
Fmt.pf fmt "%s = " k;
398
437
pp_value fmt v)
···
403
442
404
443
(* ============================================
405
444
Equality and Comparison
445
+
446
+
Both operations ignore [Meta.t]: TOML equality is by value, source
447
+
locations are incidental.
406
448
============================================ *)
407
449
408
450
let rec equal a b =
409
451
match (a, b) with
410
-
| String s1, String s2 -> String.equal s1 s2
411
-
| Int i1, Int i2 -> Int64.equal i1 i2
412
-
| Float f1, Float f2 ->
413
-
(* NaN = NaN for TOML equality *)
452
+
| String (s1, _), String (s2, _) -> String.equal s1 s2
453
+
| Int (i1, _), Int (i2, _) -> Int64.equal i1 i2
454
+
| Float (f1, _), Float (f2, _) ->
414
455
(Float.is_nan f1 && Float.is_nan f2) || Float.equal f1 f2
415
-
| Bool b1, Bool b2 -> Bool.equal b1 b2
416
-
| Datetime s1, Datetime s2 -> String.equal s1 s2
417
-
| Datetime_local s1, Datetime_local s2 -> String.equal s1 s2
418
-
| Date_local s1, Date_local s2 -> String.equal s1 s2
419
-
| Time_local s1, Time_local s2 -> String.equal s1 s2
420
-
| Array vs1, Array vs2 ->
456
+
| Bool (b1, _), Bool (b2, _) -> Bool.equal b1 b2
457
+
| Datetime (s1, _), Datetime (s2, _) -> String.equal s1 s2
458
+
| Datetime_local (s1, _), Datetime_local (s2, _) -> String.equal s1 s2
459
+
| Date_local (s1, _), Date_local (s2, _) -> String.equal s1 s2
460
+
| Time_local (s1, _), Time_local (s2, _) -> String.equal s1 s2
461
+
| Array (vs1, _), Array (vs2, _) ->
421
462
List.length vs1 = List.length vs2 && List.for_all2 equal vs1 vs2
422
-
| Table ps1, Table ps2 ->
463
+
| Table (ps1, _), Table (ps2, _) ->
423
464
List.length ps1 = List.length ps2
424
465
&& List.for_all2
425
-
(fun (k1, v1) (k2, v2) -> String.equal k1 k2 && equal v1 v2)
466
+
(fun ((k1, _), v1) ((k2, _), v2) ->
467
+
String.equal k1 k2 && equal v1 v2)
426
468
ps1 ps2
427
469
| _ -> false
428
470
···
443
485
if ta <> tb then Int.compare ta tb
444
486
else
445
487
match (a, b) with
446
-
| String s1, String s2 -> String.compare s1 s2
447
-
| Int i1, Int i2 -> Int64.compare i1 i2
448
-
| Float f1, Float f2 -> Float.compare f1 f2
449
-
| Bool b1, Bool b2 -> Bool.compare b1 b2
450
-
| Datetime s1, Datetime s2 -> String.compare s1 s2
451
-
| Datetime_local s1, Datetime_local s2 -> String.compare s1 s2
452
-
| Date_local s1, Date_local s2 -> String.compare s1 s2
453
-
| Time_local s1, Time_local s2 -> String.compare s1 s2
454
-
| Array vs1, Array vs2 -> List.compare compare vs1 vs2
455
-
| Table ps1, Table ps2 ->
488
+
| String (s1, _), String (s2, _) -> String.compare s1 s2
489
+
| Int (i1, _), Int (i2, _) -> Int64.compare i1 i2
490
+
| Float (f1, _), Float (f2, _) -> Float.compare f1 f2
491
+
| Bool (b1, _), Bool (b2, _) -> Bool.compare b1 b2
492
+
| Datetime (s1, _), Datetime (s2, _) -> String.compare s1 s2
493
+
| Datetime_local (s1, _), Datetime_local (s2, _) -> String.compare s1 s2
494
+
| Date_local (s1, _), Date_local (s2, _) -> String.compare s1 s2
495
+
| Time_local (s1, _), Time_local (s2, _) -> String.compare s1 s2
496
+
| Array (vs1, _), Array (vs2, _) -> List.compare compare vs1 vs2
497
+
| Table (ps1, _), Table (ps2, _) ->
456
498
List.compare
457
-
(fun (k1, v1) (k2, v2) ->
499
+
(fun ((k1, _), v1) ((k2, _), v2) ->
458
500
let c = String.compare k1 k2 in
459
501
if c <> 0 then c else compare v1 v2)
460
502
ps1 ps2
461
-
| _ -> 0 (* Impossible - handled by type_order check *)
462
-
463
-
(* ============================================
464
-
Error Module
465
-
============================================ *)
466
-
467
-
module Error = Error
503
+
| _ -> 0
+76
-116
ocaml-toml/lib/value.mli
+76
-116
ocaml-toml/lib/value.mli
···
6
6
(** {{:https://toml.io/en/v1.1.0}TOML 1.1} value types.
7
7
8
8
This module provides the core TOML value type and operations for
9
-
constructing, accessing, and manipulating TOML data. For parsing and
10
-
encoding, see {!Toml.Parser}. For codec-based bidirectional encoding, see
11
-
{!Toml}.
9
+
constructing, accessing, and manipulating TOML data. Every node carries a
10
+
{!Loc.Meta.t}: parsers fill it with source locations, programmatic
11
+
constructors default it to {!Loc.Meta.none}.
12
12
13
13
{2 Quick Start}
14
14
···
44
44
- {!section:access} - Value accessors and type conversion
45
45
- {!section:navigate} - Table navigation
46
46
- {!section:ptime} - Ptime datetime conversions
47
-
- {!section:pp} - Pretty printing
48
-
- {!module:Error} - Structured error types *)
47
+
- {!section:pp} - Pretty printing *)
49
48
50
49
(** {1:types TOML Value Types} *)
51
50
51
+
module Meta = Loc.Meta
52
+
(** Node metadata (source location + surrounding whitespace). *)
53
+
54
+
type 'a node = 'a Loc.node
55
+
(** An AST node: data plus its metadata. *)
56
+
57
+
type name = string node
58
+
(** The type for TOML table keys. A key's {!Loc.Meta.t} points at its source
59
+
position in the document (for bare, quoted, or dotted keys). *)
60
+
52
61
(** The type of TOML values.
62
+
63
+
Every constructor wraps its payload in an {!node}: the parser fills the
64
+
metadata with source positions; programmatic constructors default it to
65
+
{!Loc.Meta.none}.
53
66
54
67
TOML supports the following value types:
55
68
- {{:https://toml.io/en/v1.1.0#string}Strings} (UTF-8 encoded)
···
65
78
- {{:https://toml.io/en/v1.1.0#array}Arrays} (heterogeneous in TOML 1.1)
66
79
- {{:https://toml.io/en/v1.1.0#table}Tables} (string-keyed maps) *)
67
80
type t =
68
-
| String of string (** {{:https://toml.io/en/v1.1.0#string}TOML string}. *)
69
-
| Int of int64 (** {{:https://toml.io/en/v1.1.0#integer}TOML integer}. *)
70
-
| Float of float (** {{:https://toml.io/en/v1.1.0#float}TOML float}. *)
71
-
| Bool of bool (** {{:https://toml.io/en/v1.1.0#boolean}TOML boolean}. *)
72
-
| Datetime of string
81
+
| String of string node
82
+
(** {{:https://toml.io/en/v1.1.0#string}TOML string}. *)
83
+
| Int of int64 node
84
+
(** {{:https://toml.io/en/v1.1.0#integer}TOML integer}. *)
85
+
| Float of float node (** {{:https://toml.io/en/v1.1.0#float}TOML float}. *)
86
+
| Bool of bool node
87
+
(** {{:https://toml.io/en/v1.1.0#boolean}TOML boolean}. *)
88
+
| Datetime of string node
73
89
(** {{:https://toml.io/en/v1.1.0#offset-date-time}Offset datetime}, e.g.
74
90
[1979-05-27T07:32:00Z]. *)
75
-
| Datetime_local of string
91
+
| Datetime_local of string node
76
92
(** {{:https://toml.io/en/v1.1.0#local-date-time}Local datetime}, e.g.
77
93
[1979-05-27T07:32:00]. *)
78
-
| Date_local of string
94
+
| Date_local of string node
79
95
(** {{:https://toml.io/en/v1.1.0#local-date}Local date}, e.g.
80
96
[1979-05-27]. *)
81
-
| Time_local of string
97
+
| Time_local of string node
82
98
(** {{:https://toml.io/en/v1.1.0#local-time}Local time}, e.g. [07:32:00].
83
99
*)
84
-
| Array of t list (** {{:https://toml.io/en/v1.1.0#array}TOML array}. *)
85
-
| Table of (string * t) list
86
-
(** {{:https://toml.io/en/v1.1.0#table}TOML table}. *)
87
-
(** A TOML value. Tables preserve key insertion order. *)
100
+
| Array of t list node (** {{:https://toml.io/en/v1.1.0#array}TOML array}. *)
101
+
| Table of (name * t) list node
102
+
(** {{:https://toml.io/en/v1.1.0#table}TOML table}. Preserves key
103
+
insertion order. Each key's metadata points at its source position. *)
104
+
105
+
val meta : t -> Meta.t
106
+
(** [meta v] is the source metadata of [v]'s top-level constructor. *)
88
107
89
108
(** {1:construct Value Constructors}
90
109
91
-
These functions create TOML values. Use them to build TOML documents
92
-
programmatically. *)
110
+
These functions create TOML values. Each accepts an optional [?meta]
111
+
(defaults to {!Loc.Meta.none}). *)
93
112
94
-
val string : string -> t
113
+
val string : ?meta:Meta.t -> string -> t
95
114
(** [string s] creates a {{:https://toml.io/en/v1.1.0#string}TOML string} value.
96
115
*)
97
116
98
-
val int : int64 -> t
117
+
val int : ?meta:Meta.t -> int64 -> t
99
118
(** [int i] creates a {{:https://toml.io/en/v1.1.0#integer}TOML integer} value.
100
119
*)
101
120
102
-
val int_of_int : int -> t
121
+
val int_of_int : ?meta:Meta.t -> int -> t
103
122
(** [int_of_int i] creates a {{:https://toml.io/en/v1.1.0#integer}TOML integer}
104
123
value from an [int]. *)
105
124
106
-
val float : float -> t
125
+
val float : ?meta:Meta.t -> float -> t
107
126
(** [float f] creates a {{:https://toml.io/en/v1.1.0#float}TOML float} value. *)
108
127
109
-
val bool : bool -> t
128
+
val bool : ?meta:Meta.t -> bool -> t
110
129
(** [bool b] creates a {{:https://toml.io/en/v1.1.0#boolean}TOML boolean} value.
111
130
*)
112
131
113
-
val array : t list -> t
132
+
val array : ?meta:Meta.t -> t list -> t
114
133
(** [array vs] creates a {{:https://toml.io/en/v1.1.0#array}TOML array} value
115
134
from a list of values. TOML 1.1 allows heterogeneous arrays. *)
116
135
117
-
val table : (string * t) list -> t
136
+
val table : ?meta:Meta.t -> (string * t) list -> t
118
137
(** [table pairs] creates a {{:https://toml.io/en/v1.1.0#table}TOML table} value
119
-
from key-value pairs. Keys should be unique; later bindings shadow earlier
120
-
ones during lookup. *)
138
+
from key-value pairs. Keys are wrapped with {!Loc.Meta.none}; use the
139
+
underlying [Table] constructor directly to preserve key metadata. *)
121
140
122
-
val datetime : string -> t
141
+
val datetime : ?meta:Meta.t -> string -> t
123
142
(** [datetime s] creates an
124
-
{{:https://toml.io/en/v1.1.0#offset-date-time}offset datetime} value. The
125
-
string should be in RFC 3339 format with timezone, e.g.
126
-
["1979-05-27T07:32:00Z"] or ["1979-05-27T07:32:00-07:00"]. *)
143
+
{{:https://toml.io/en/v1.1.0#offset-date-time}offset datetime} value. *)
127
144
128
-
val datetime_local : string -> t
145
+
val datetime_local : ?meta:Meta.t -> string -> t
129
146
(** [datetime_local s] creates a
130
-
{{:https://toml.io/en/v1.1.0#local-date-time}local datetime} value (no
131
-
timezone). E.g. ["1979-05-27T07:32:00"]. *)
147
+
{{:https://toml.io/en/v1.1.0#local-date-time}local datetime} value. *)
132
148
133
-
val date_local : string -> t
149
+
val date_local : ?meta:Meta.t -> string -> t
134
150
(** [date_local s] creates a {{:https://toml.io/en/v1.1.0#local-date}local date}
135
-
value. E.g. ["1979-05-27"]. *)
151
+
value. *)
136
152
137
-
val time_local : string -> t
153
+
val time_local : ?meta:Meta.t -> string -> t
138
154
(** [time_local s] creates a {{:https://toml.io/en/v1.1.0#local-time}local time}
139
-
value. E.g. ["07:32:00"] or ["07:32:00.999"]. *)
155
+
value. *)
140
156
141
157
(** {1:access Value Accessors}
142
158
143
-
These functions extract OCaml values from TOML values. They raise
144
-
[Invalid_argument] if the value is not of the expected type. *)
159
+
These functions extract OCaml values from TOML values, discarding the
160
+
surrounding metadata. They raise [Invalid_argument] if the value is not of
161
+
the expected type. *)
145
162
146
163
val to_string : t -> string
147
164
(** [to_string t] returns the string if [t] is a [String].
···
182
199
*)
183
200
184
201
val to_table : t -> (string * t) list
185
-
(** [to_table t] returns the association list if [t] is a
186
-
{{:https://toml.io/en/v1.1.0#table}TOML table}.
202
+
(** [to_table t] returns the table's key-value pairs as a plain association list
203
+
(key metadata is discarded).
187
204
@raise Invalid_argument if [t] is not a table. *)
188
205
189
206
val to_table_opt : t -> (string * t) list option
190
-
(** [to_table_opt t] returns [Some pairs] if [t] is [Table pairs], [None]
191
-
otherwise. *)
207
+
(** [to_table_opt t] returns [Some pairs] if [t] is a [Table], [None] otherwise.
208
+
*)
192
209
193
210
val to_datetime : t -> string
194
211
(** [to_datetime t] returns the datetime string for any datetime type.
···
240
257
Returns [false] if [t] is not a table. *)
241
258
242
259
val keys : t -> string list
243
-
(** [keys t] returns all keys in table [t].
260
+
(** [keys t] returns all keys in table [t] as plain strings.
244
261
@raise Invalid_argument if [t] is not a table. *)
245
262
246
263
val ( .%{} ) : t -> string list -> t
···
260
277
(** [t .%{path} <- v] sets the value [v] at [path], returning a new table.
261
278
Creates intermediate tables as needed.
262
279
263
-
Example: [config.%{["server"; "host"]} <- string "localhost"]
264
-
265
280
@raise Invalid_argument
266
281
if [t] is not a table or if an intermediate value exists but is not a
267
282
table. *)
···
269
284
(** {1:ptime Ptime Conversions}
270
285
271
286
Convert between {{:https://toml.io/en/v1.1.0#offset-date-time}TOML datetime}
272
-
values and {{:https://erratique.ch/software/ptime}Ptime} timestamps. Offset
273
-
datetimes can be converted to/from [Ptime.t] since they represent specific
274
-
instants on the UTC timeline. Local datetime types cannot be converted to
275
-
[Ptime.t] without assuming a timezone. *)
287
+
values and {{:https://erratique.ch/software/ptime}Ptime} timestamps. *)
276
288
277
289
val datetime_of_ptime : ?tz_offset_s:int -> ?frac_s:int -> Ptime.t -> t
278
290
(** [datetime_of_ptime ?tz_offset_s ?frac_s ptime] creates an
279
291
{{:https://toml.io/en/v1.1.0#offset-date-time}offset datetime} from a ptime
280
-
timestamp.
281
-
@param tz_offset_s
282
-
Timezone offset in seconds (default: 0 for UTC). Use positive values for
283
-
east of UTC (e.g., 3600 for +01:00), negative for west (e.g., -18000 for
284
-
-05:00).
285
-
@param frac_s
286
-
Number of fractional second digits to include (default: 0). Clipped to
287
-
range \[0, 12\]. *)
292
+
timestamp. *)
288
293
289
294
val to_ptime : t -> Ptime.t
290
295
(** [to_ptime t] converts an
291
296
{{:https://toml.io/en/v1.1.0#offset-date-time}offset datetime} to a ptime
292
297
timestamp.
293
298
@raise Invalid_argument
294
-
if [t] is not a [Datetime] or if the datetime string cannot be parsed.
295
-
Local datetime types cannot be converted. *)
299
+
if [t] is not a [Datetime] or if the datetime string cannot be parsed. *)
296
300
297
301
val to_ptime_opt : t -> Ptime.t option
298
302
(** [to_ptime_opt t] returns [Some ptime] if [t] is a [Datetime] that can be
···
300
304
301
305
val to_ptime_tz : t -> (Ptime.t * Ptime.tz_offset_s option) option
302
306
(** [to_ptime_tz t] returns the ptime timestamp and timezone offset for an
303
-
offset datetime. The timezone is [Some 0] for [Z], [Some offset_s] for
304
-
explicit offsets like [+05:30], or [None] for the unknown local offset
305
-
convention ([-00:00]). Returns [None] if [t] is not a [Datetime]. *)
307
+
offset datetime. *)
306
308
307
309
val date_of_ptime : ?tz_offset_s:int -> Ptime.t -> t
308
310
(** [date_of_ptime ?tz_offset_s ptime] creates a
309
311
{{:https://toml.io/en/v1.1.0#local-date}local date} from a ptime timestamp.
310
-
The date is extracted in the given timezone (default: UTC). *)
312
+
*)
311
313
312
314
val to_date : t -> Ptime.date
313
315
(** [to_date t] converts a {{:https://toml.io/en/v1.1.0#local-date}local date}
···
321
323
(** {2:ptime_unified Unified Ptime Datetime}
322
324
323
325
Unifies all {{:https://toml.io/en/v1.1.0#offset-date-time}TOML datetime}
324
-
formats using {!Ptime} types, while preserving information about what was
325
-
originally specified in the TOML source.
326
-
327
-
For {{:https://toml.io/en/v1.1.0#local-date-time}local datetimes} without
328
-
timezone, pass [~tz_offset_s] to specify the timezone to use for conversion.
329
-
If not provided, UTC (0) is used as the default. *)
326
+
formats using {!Ptime} types. *)
330
327
331
328
type ptime_datetime =
332
329
[ `Datetime of Ptime.t * Ptime.tz_offset_s option
333
-
(** {{:https://toml.io/en/v1.1.0#offset-date-time}Offset datetime} with full
334
-
timezone info. The offset is [Some 0] for [Z], [Some n] for explicit
335
-
offsets, or [None] for the unknown local offset convention ([-00:00]).
336
-
*)
337
330
| `Datetime_local of Ptime.t
338
-
(** {{:https://toml.io/en/v1.1.0#local-date-time}Local datetime} converted
339
-
to [Ptime.t] using current system timezone. Preserves that the source
340
-
had no explicit timezone. *)
341
331
| `Date of Ptime.date
342
-
(** {{:https://toml.io/en/v1.1.0#local-date}Local date} as
343
-
[(year, month, day)]. *)
344
-
| `Time of int * int * int * int
345
-
(** {{:https://toml.io/en/v1.1.0#local-time}Local time} as
346
-
[(hour, minute, second, nanoseconds)]. Nanoseconds range from 0 to
347
-
999_999_999. *) ]
348
-
(** Datetime representation using {!Ptime}.
349
-
350
-
This variant indicates both the ptime value and the precision level of
351
-
datetime information present in the original TOML source. *)
332
+
| `Time of int * int * int * int ]
333
+
(** Datetime representation using {!Ptime}. *)
352
334
353
335
val to_ptime_datetime : ?tz_offset_s:int -> t -> ptime_datetime option
354
336
(** [to_ptime_datetime ?tz_offset_s t] converts any TOML datetime value to a
355
-
unified ptime representation.
356
-
357
-
@param tz_offset_s
358
-
Timezone offset for local datetimes. This is the offset to assume when the
359
-
TOML value is a local datetime without explicit timezone. Defaults to 0
360
-
(UTC) if not provided.
361
-
@return [None] if [t] is not a datetime type, [Some pdt] otherwise.
362
-
363
-
Examples:
364
-
- [Datetime "1979-05-27T07:32:00Z"] → [Some (`Datetime (ptime, Some 0))]
365
-
- [Datetime_local "1979-05-27T07:32:00"] → [Some (`Datetime_local ptime)]
366
-
(converted using current tz)
367
-
- [Date_local "1979-05-27"] → [Some (`Date (1979, 5, 27))]
368
-
- [Time_local "07:32:00.123"] → [Some (`Time (7, 32, 0, 123_000_000))]. *)
337
+
unified ptime representation. *)
369
338
370
339
val ptime_datetime_to_toml : ptime_datetime -> t
371
340
(** [ptime_datetime_to_toml pdt] converts a unified ptime datetime back to a
372
-
TOML value, preserving the appropriate datetime variant:
373
-
- [`Datetime (t, tz)] → [Datetime s] with timezone
374
-
- [`Datetime_local t] → [Datetime_local s]
375
-
- [`Date d] → [Date_local s]
376
-
- [`Time (h, m, s, ns)] → [Time_local s]. *)
341
+
TOML value. *)
377
342
378
343
val pp_ptime_datetime : Format.formatter -> ptime_datetime -> unit
379
344
(** [pp_ptime_datetime fmt pdt] pretty-prints the unified datetime. *)
···
382
347
383
348
val pp : Format.formatter -> t -> unit
384
349
(** [pp fmt t] pretty-prints [t] in TOML inline format. Tables are printed as
385
-
inline tables. *)
350
+
inline tables. Metadata is ignored. *)
386
351
387
352
val pp_value : Format.formatter -> t -> unit
388
353
(** [pp_value fmt t] pretty-prints a single TOML value. Same as {!val:pp}. *)
389
354
390
355
val equal : t -> t -> bool
391
356
(** [equal a b] is structural equality on TOML values. NaN floats are considered
392
-
equal to each other. *)
357
+
equal to each other. Ignores metadata. *)
393
358
394
359
val compare : t -> t -> int
395
-
(** [compare a b] is a total ordering on TOML values. *)
396
-
397
-
(** {1:errors Error Handling} *)
398
-
399
-
module Error = Error
400
-
(** Structured error types for TOML parsing and encoding. *)
360
+
(** [compare a b] is a total ordering on TOML values. Ignores metadata. *)
+34
-15
ocaml-toml/test/test_codec.ml
+34
-15
ocaml-toml/test/test_codec.ml
···
1109
1109
{
1110
1110
name = "test";
1111
1111
extras =
1112
-
[ ("custom", Toml.Value.Int 42L); ("flag", Toml.Value.Bool true) ];
1112
+
[ ("custom", Toml.Value.int 42L); ("flag", Toml.Value.bool true) ];
1113
1113
}
1114
1114
in
1115
1115
check_roundtrip "keep_unknown roundtrip" extensible_config_codec c
···
1181
1181
Any/Value Codec Tests
1182
1182
============================================================================ *)
1183
1183
1184
+
(* value codec comparisons must ignore metadata, so we can't use the generic
1185
+
check_decode_ok (which uses structural [=]). *)
1186
+
let check_decode_value_ok name input expected =
1187
+
let toml = Toml.Parser.parse input in
1188
+
let v = Toml.Value.get "value" toml in
1189
+
match Private.of_toml value v with
1190
+
| Ok v when Toml.Value.equal v expected -> ()
1191
+
| Ok _ -> Alcotest.failf "%s: decode returned unexpected value" name
1192
+
| Error e ->
1193
+
Alcotest.failf "%s: decode failed: %s" name (Toml.Error.to_string e)
1194
+
1195
+
let check_roundtrip_value name v =
1196
+
let encoded = Private.to_toml value v in
1197
+
match Private.of_toml value encoded with
1198
+
| Ok v' when Toml.Value.equal v v' -> ()
1199
+
| Ok _ -> Alcotest.failf "%s: roundtrip changed value" name
1200
+
| Error e ->
1201
+
Alcotest.failf "%s: roundtrip failed: %s" name (Toml.Error.to_string e)
1202
+
1184
1203
let test_value_codec () =
1185
-
check_decode_ok "int" value "value = 42" (Toml.Value.Int 42L);
1186
-
check_decode_ok "string" value {|value = "hello"|} (Toml.Value.String "hello");
1187
-
check_decode_ok "bool" value "value = true" (Toml.Value.Bool true);
1188
-
check_decode_ok "float" value "value = 3.14" (Toml.Value.Float 3.14);
1189
-
check_decode_ok "array" value "value = [1, 2, 3]"
1190
-
(Toml.Value.Array
1191
-
[ Toml.Value.Int 1L; Toml.Value.Int 2L; Toml.Value.Int 3L ])
1204
+
check_decode_value_ok "int" "value = 42" (Toml.Value.int 42L);
1205
+
check_decode_value_ok "string" {|value = "hello"|} (Toml.Value.string "hello");
1206
+
check_decode_value_ok "bool" "value = true" (Toml.Value.bool true);
1207
+
check_decode_value_ok "float" "value = 3.14" (Toml.Value.float 3.14);
1208
+
check_decode_value_ok "array" "value = [1, 2, 3]"
1209
+
(Toml.Value.array
1210
+
[ Toml.Value.int 1L; Toml.Value.int 2L; Toml.Value.int 3L ])
1192
1211
1193
1212
let test_value_roundtrip () =
1194
-
check_roundtrip "int" value (Toml.Value.Int 42L);
1195
-
check_roundtrip "string" value (Toml.Value.String "hello");
1196
-
check_roundtrip "bool" value (Toml.Value.Bool true)
1213
+
check_roundtrip_value "int" (Toml.Value.int 42L);
1214
+
check_roundtrip_value "string" (Toml.Value.string "hello");
1215
+
check_roundtrip_value "bool" (Toml.Value.bool true)
1197
1216
1198
1217
let test_value_mems_codec () =
1199
1218
let input = {|
···
1469
1488
| exception Toml.Invalid_utf8_encode i ->
1470
1489
Alcotest.(check int) "offset 4 inside 'bad-\\xC3'" 4 i
1471
1490
1472
-
(* Malformed byte inside a table key. We build a raw Toml.Value.Table with
1491
+
(* Malformed byte inside a table key. We build a raw Toml.Value.table with
1473
1492
the bad bytes in the key name and round it through the [value]
1474
1493
codec so [encode_string] validates it. *)
1475
1494
let test_encode_bad_utf8_key () =
1476
-
let bad = Toml.Value.Table [ ("ok\xFF", Toml.Value.Int 1L) ] in
1495
+
let bad = Toml.Value.table [ ("ok\xFF", Toml.Value.int 1L) ] in
1477
1496
match Toml.to_string value bad with
1478
1497
| _ -> Alcotest.fail "expected Invalid_utf8_encode"
1479
1498
| exception Toml.Invalid_utf8_encode i ->
1480
1499
Alcotest.(check int) "offset 2 inside 'ok\\xFF'" 2 i
1481
1500
1482
-
(* Datetime values are stored as strings. A Toml.Value.Datetime carrying
1501
+
(* Datetime values are stored as strings. A Toml.Value.datetime carrying
1483
1502
malformed bytes is still a string that must be validated. *)
1484
1503
let test_encode_bad_utf8_dt () =
1485
1504
let bad =
1486
-
Toml.Value.Table [ ("d", Toml.Value.Datetime "1979-05-27T07:32:00\xC3") ]
1505
+
Toml.Value.table [ ("d", Toml.Value.datetime "1979-05-27T07:32:00\xC3") ]
1487
1506
in
1488
1507
match Toml.to_string value bad with
1489
1508
| _ -> Alcotest.fail "expected Invalid_utf8_encode"
+5
-5
ocaml-toml/test/test_debug.ml
+5
-5
ocaml-toml/test/test_debug.ml
···
24
24
(* Show raw structure *)
25
25
Fmt.pr "\nRaw structure: %s\n"
26
26
(match toml with
27
-
| Value.Table pairs ->
27
+
| Value.Table (pairs, _) ->
28
28
String.concat ", "
29
29
(List.map
30
-
(fun (k, v) ->
30
+
(fun ((k, _), v) ->
31
31
Fmt.str "%s=%s" k
32
32
(match v with
33
-
| Value.String s -> Fmt.str "\"%s\"" s
34
-
| Value.Bool b -> string_of_bool b
35
-
| Value.Int i -> Int64.to_string i
33
+
| Value.String (s, _) -> Fmt.str "\"%s\"" s
34
+
| Value.Bool (b, _) -> string_of_bool b
35
+
| Value.Int (i, _) -> Int64.to_string i
36
36
| _ -> "?"))
37
37
pairs)
38
38
| _ -> "not a table");
+213
-9
ocaml-toml/test/test_error.ml
+213
-9
ocaml-toml/test/test_error.ml
···
1
-
let test_parse_error_message () =
2
-
match Toml.Parser.of_string "invalid = [unclosed" with
3
-
| Ok _ -> Alcotest.fail "expected parse error"
4
-
| Error e ->
5
-
let msg = Toml.Value.Error.to_string e in
6
-
Alcotest.(check bool)
7
-
"non-empty error message" true
8
-
(String.length msg > 0)
1
+
(* Negative parser tests.
2
+
3
+
Each test feeds the parser a deliberately bad TOML document and
4
+
asserts on the exact shape of the resulting [Loc.Error.t]:
5
+
6
+
- structural match on the typed {!Toml.Error.kind},
7
+
- exact line/column/file from the error's [Loc.Meta.t],
8
+
- exact formatted output of {!Toml.Error.to_string}.
9
+
10
+
Tests are split across "typed" inputs (parser.ml's typed raise-path
11
+
produces a [Loc.Error.t] with a populated [meta]) and "fallback"
12
+
inputs (the parser's [Fmt.failwith] path which is caught by
13
+
[of_string] and wrapped as [Syntax (Expected _)] with
14
+
[Loc.Meta.none]). Tests in the fallback group assert only on the
15
+
typed kind and rendered message, not on position. *)
16
+
17
+
module Error = Toml.Error
18
+
19
+
let parse_err what s =
20
+
match Toml.Parser.of_string s with
21
+
| Ok _ -> Alcotest.failf "expected parse error for %s, got Ok" what
22
+
| Error e -> e
23
+
24
+
(* --- Error-field extractors --- *)
25
+
26
+
let loc e = Loc.Meta.textloc e.Loc.Error.meta
27
+
let line e = Loc.first_line_num (loc e)
28
+
29
+
let col e =
30
+
let l = loc e in
31
+
Loc.first_byte l - Loc.first_line_byte l + 1
32
+
33
+
let file e = Loc.file (loc e)
34
+
let meta_is_none e = Loc.Meta.is_none e.Loc.Error.meta
35
+
let ctx_is_empty e = Loc.Context.is_empty e.Loc.Error.ctx
36
+
37
+
(* --- Position asserts --- *)
38
+
39
+
let check_line what e ~line:expected =
40
+
Alcotest.(check int) (what ^ ": line") expected (line e)
41
+
42
+
let check_col what e ~col:expected =
43
+
Alcotest.(check int) (what ^ ": col") expected (col e)
44
+
45
+
let check_file what e ~file:expected =
46
+
Alcotest.(check string) (what ^ ": file") expected (file e)
47
+
48
+
let check_no_meta what e =
49
+
Alcotest.(check bool)
50
+
(what ^ ": meta is none (fallback path)")
51
+
true (meta_is_none e)
52
+
53
+
let check_ctx_empty what e =
54
+
Alcotest.(check bool)
55
+
(what ^ ": ctx empty at parser boundary")
56
+
true (ctx_is_empty e)
57
+
58
+
let check_rendered what e ~expected =
59
+
Alcotest.(check string)
60
+
(what ^ ": Error.to_string")
61
+
expected (Error.to_string e)
62
+
63
+
(* =============================================
64
+
Typed lexer errors (Error.Lexer _ with real meta)
65
+
============================================= *)
66
+
67
+
let test_invalid_utf8_in_string () =
68
+
let e = parse_err "invalid UTF-8" "k = \"\xff\"" in
69
+
(match e.Loc.Error.kind with
70
+
| Error.Lexer Error.Invalid_utf8 -> ()
71
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k));
72
+
check_file "invalid UTF-8" e ~file:"-";
73
+
check_line "invalid UTF-8" e ~line:1;
74
+
check_col "invalid UTF-8" e ~col:6;
75
+
check_ctx_empty "invalid UTF-8" e;
76
+
check_rendered "invalid UTF-8" e
77
+
~expected:"invalid UTF-8 sequence\nFile \"-\", line 1, characters 5-6:"
78
+
79
+
let test_invalid_utf8_on_later_line () =
80
+
let e = parse_err "UTF-8 on line 3" "a = 1\nb = 2\nk = \"\xff\"" in
81
+
(match e.Loc.Error.kind with
82
+
| Error.Lexer Error.Invalid_utf8 -> ()
83
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k));
84
+
check_line "UTF-8 line 3" e ~line:3;
85
+
check_col "UTF-8 line 3" e ~col:6
86
+
87
+
let test_control_char_in_string () =
88
+
let e = parse_err "control char" "k = \"\x01\"" in
89
+
(match e.Loc.Error.kind with
90
+
| Error.Lexer (Error.Control_character 0x01) -> ()
91
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k));
92
+
check_line "control char" e ~line:1;
93
+
check_col "control char" e ~col:6;
94
+
check_rendered "control char" e
95
+
~expected:
96
+
"control character U+0001 not allowed\n\
97
+
File \"-\", line 1, characters 5-6:"
98
+
99
+
let test_surrogate_escape () =
100
+
let e = parse_err "surrogate" {|k = "\uD800"|} in
101
+
match e.Loc.Error.kind with
102
+
| Error.Lexer (Error.Surrogate_codepoint 0xD800) ->
103
+
check_line "surrogate" e ~line:1;
104
+
check_rendered "surrogate" e
105
+
~expected:
106
+
"surrogate codepoint not allowed: U+D800\n\
107
+
File \"-\", line 1, characters 11-12:"
108
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
109
+
110
+
let test_invalid_unicode_codepoint () =
111
+
let e = parse_err "codepoint overflow" {|k = "\U00110000"|} in
112
+
match e.Loc.Error.kind with
113
+
| Error.Lexer (Error.Invalid_unicode_codepoint 0x110000) ->
114
+
check_line "codepoint overflow" e ~line:1
115
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
116
+
117
+
let test_incomplete_unicode_escape () =
118
+
(* Only 3 hex digits after \u (requires 4). *)
119
+
let e = parse_err "short \\u escape" {|k = "\u123|} in
120
+
(match e.Loc.Error.kind with
121
+
| Error.Lexer (Error.Invalid_unicode_escape "\\u") -> ()
122
+
| Error.Lexer (Error.Incomplete_escape "\\u") -> ()
123
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k));
124
+
check_line "short \\u escape" e ~line:1
125
+
126
+
(* =============================================
127
+
Fallback-path errors (Failure -> Syntax(Expected msg)).
128
+
129
+
These tests assert kind + full rendered message; they deliberately
130
+
do NOT assert line/col because the fallback path discards the meta.
131
+
============================================= *)
132
+
133
+
let test_fallback_has_none_meta () =
134
+
let e = parse_err "missing equals" "key value" in
135
+
(match e.Loc.Error.kind with
136
+
| Error.Syntax (Error.Expected _) -> ()
137
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k));
138
+
check_no_meta "missing equals" e;
139
+
check_ctx_empty "missing equals" e
140
+
141
+
let test_fallback_bare_cr () =
142
+
(* Bare CR at top level hits next_token's Fmt.failwith, not the typed
143
+
string-context raise. *)
144
+
let e = parse_err "bare CR top-level" "x\r= 1" in
145
+
match e.Loc.Error.kind with
146
+
| Error.Syntax (Error.Expected msg) ->
147
+
Alcotest.(check string)
148
+
"bare CR: expected payload" "Bare carriage return not allowed at line 1"
149
+
msg
150
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
151
+
152
+
let test_fallback_unclosed_array () =
153
+
let e = parse_err "unclosed array" "k = [1, 2, 3" in
154
+
match e.Loc.Error.kind with
155
+
| Error.Syntax (Error.Expected _) -> ()
156
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
157
+
158
+
let test_fallback_unclosed_inline_table () =
159
+
let e = parse_err "unclosed inline" "k = { a = 1, b = 2" in
160
+
match e.Loc.Error.kind with
161
+
| Error.Syntax (Error.Expected _) -> ()
162
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
163
+
164
+
let test_fallback_bare_key_as_value () =
165
+
let e = parse_err "bare key as value" "k = foo" in
166
+
match e.Loc.Error.kind with
167
+
| Error.Syntax (Error.Expected msg) ->
168
+
Alcotest.(check string)
169
+
"bare key: expected payload" "Unexpected bare key 'foo' as value" msg
170
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
171
+
172
+
let test_fallback_duplicate_key () =
173
+
let e = parse_err "duplicate key" "k = 1\nk = 2" in
174
+
match e.Loc.Error.kind with
175
+
| Error.Syntax (Error.Expected msg) ->
176
+
Alcotest.(check string) "dup: expected payload" "Duplicate key: k" msg
177
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
178
+
179
+
let test_fallback_redefine_table () =
180
+
let e = parse_err "redefine table" "[a]\nb = 1\n[a]\nc = 2" in
181
+
match e.Loc.Error.kind with
182
+
| Error.Syntax (Error.Expected msg) ->
183
+
Alcotest.(check string)
184
+
"redefine: expected payload" "Table 'a' already defined" msg
185
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
186
+
187
+
let test_fallback_redefine_value_as_table () =
188
+
(* Define a value at the root, then open a table with the same name. *)
189
+
let e = parse_err "value-as-table" "a = 1\n[a]\nb = 2" in
190
+
match e.Loc.Error.kind with
191
+
| Error.Syntax (Error.Expected _) -> ()
192
+
| k -> Alcotest.failf "kind: %s" (Error.kind_to_string k)
9
193
10
194
let suite =
11
-
("error", [ ("parse error message", `Quick, test_parse_error_message) ])
195
+
( "error",
196
+
[
197
+
(* typed-path lexer errors *)
198
+
("typed: invalid UTF-8", `Quick, test_invalid_utf8_in_string);
199
+
("typed: UTF-8 on line 3", `Quick, test_invalid_utf8_on_later_line);
200
+
("typed: control char", `Quick, test_control_char_in_string);
201
+
("typed: surrogate escape", `Quick, test_surrogate_escape);
202
+
("typed: codepoint overflow", `Quick, test_invalid_unicode_codepoint);
203
+
("typed: short \\u escape", `Quick, test_incomplete_unicode_escape);
204
+
(* fallback-path errors *)
205
+
("fallback: no meta", `Quick, test_fallback_has_none_meta);
206
+
("fallback: bare CR", `Quick, test_fallback_bare_cr);
207
+
("fallback: unclosed array", `Quick, test_fallback_unclosed_array);
208
+
("fallback: unclosed inline", `Quick, test_fallback_unclosed_inline_table);
209
+
("fallback: bare key as value", `Quick, test_fallback_bare_key_as_value);
210
+
("fallback: duplicate key", `Quick, test_fallback_duplicate_key);
211
+
("fallback: redefine table", `Quick, test_fallback_redefine_table);
212
+
( "fallback: redefine value as table",
213
+
`Quick,
214
+
test_fallback_redefine_value_as_table );
215
+
] )
+24
-24
ocaml-toml/test/test_toml.ml
+24
-24
ocaml-toml/test/test_toml.ml
···
14
14
15
15
module V = Toml.Value
16
16
17
-
let toml_table pairs = V.Table pairs
18
-
let toml_array items = V.Array items
17
+
let toml_table pairs = V.table pairs
18
+
let toml_array items = V.array items
19
19
20
20
let test_get_key () =
21
21
let tbl =
22
-
toml_table [ ("host", V.String "localhost"); ("port", V.Int 8080L) ]
22
+
toml_table [ ("host", V.string "localhost"); ("port", V.int 8080L) ]
23
23
in
24
24
let c = Toml.key "host" Toml.string in
25
25
match Toml.Private.of_toml c tbl with
···
27
27
| Error e -> Alcotest.failf "key failed: %s" (Toml.Error.to_string e)
28
28
29
29
let test_get_key_missing () =
30
-
let tbl = toml_table [ ("host", V.String "localhost") ] in
30
+
let tbl = toml_table [ ("host", V.string "localhost") ] in
31
31
let c = Toml.key "port" Toml.int in
32
32
match Toml.Private.of_toml c tbl with
33
33
| Error _ -> ()
···
35
35
36
36
let test_get_key_not_table () =
37
37
let c = Toml.key "x" Toml.string in
38
-
match Toml.Private.of_toml c (V.String "hello") with
38
+
match Toml.Private.of_toml c (V.string "hello") with
39
39
| Error _ -> ()
40
40
| Ok _ -> Alcotest.fail "key should error on non-table"
41
41
···
44
44
toml_table
45
45
[
46
46
( "server",
47
-
toml_table [ ("host", V.String "example.com"); ("port", V.Int 443L) ]
47
+
toml_table [ ("host", V.string "example.com"); ("port", V.int 443L) ]
48
48
);
49
49
]
50
50
in
···
58
58
let v = Toml.Private.to_toml c "alice" in
59
59
Alcotest.(check bool)
60
60
"key encodes to table" true
61
-
(Toml.Value.equal v (toml_table [ ("name", V.String "alice") ]))
61
+
(Toml.Value.equal v (toml_table [ ("name", V.string "alice") ]))
62
62
63
63
let test_get_nth () =
64
-
let arr = toml_array [ V.String "a"; V.String "b"; V.String "c" ] in
64
+
let arr = toml_array [ V.string "a"; V.string "b"; V.string "c" ] in
65
65
let c = Toml.nth 1 Toml.string in
66
66
match Toml.Private.of_toml c arr with
67
67
| Ok s -> Alcotest.(check string) "nth 1" "b" s
68
68
| Error e -> Alcotest.failf "nth failed: %s" (Toml.Error.to_string e)
69
69
70
70
let test_get_nth_zero () =
71
-
let arr = toml_array [ V.Int 42L ] in
71
+
let arr = toml_array [ V.int 42L ] in
72
72
let c = Toml.nth 0 Toml.int in
73
73
match Toml.Private.of_toml c arr with
74
74
| Ok i -> Alcotest.(check int) "nth 0" 42 i
75
75
| Error e -> Alcotest.failf "nth 0 failed: %s" (Toml.Error.to_string e)
76
76
77
77
let test_nth_out_of_bounds () =
78
-
let arr = toml_array [ V.String "a" ] in
78
+
let arr = toml_array [ V.string "a" ] in
79
79
let c = Toml.nth 5 Toml.string in
80
80
match Toml.Private.of_toml c arr with
81
81
| Error _ -> ()
···
83
83
84
84
let test_get_nth_not_array () =
85
85
let c = Toml.nth 0 Toml.string in
86
-
match Toml.Private.of_toml c (V.String "hello") with
86
+
match Toml.Private.of_toml c (V.string "hello") with
87
87
| Error _ -> ()
88
88
| Ok _ -> Alcotest.fail "nth should error on non-array"
89
89
···
92
92
let v = Toml.Private.to_toml c 99 in
93
93
Alcotest.(check bool)
94
94
"nth encodes to array" true
95
-
(Toml.Value.equal v (toml_array [ V.Int 99L ]))
95
+
(Toml.Value.equal v (toml_array [ V.int 99L ]))
96
96
97
97
(* ---- Update tests ---- *)
98
98
99
99
let toml_t = Alcotest.testable Toml.Value.pp Toml.Value.equal
100
100
101
101
let test_update_key () =
102
-
let tbl = toml_table [ ("name", V.String "alice"); ("age", V.Int 30L) ] in
102
+
let tbl = toml_table [ ("name", V.string "alice"); ("age", V.int 30L) ] in
103
103
(* update_key with a map that uppercases strings *)
104
104
let c =
105
105
Toml.update_key "name"
···
108
108
match Toml.Private.of_toml c tbl with
109
109
| Ok result ->
110
110
let expected =
111
-
toml_table [ ("name", V.String "ALICE"); ("age", V.Int 30L) ]
111
+
toml_table [ ("name", V.string "ALICE"); ("age", V.int 30L) ]
112
112
in
113
113
Alcotest.(check toml_t) "update_key capitalizes name" expected result
114
114
| Error e -> Alcotest.failf "update_key failed: %s" (Toml.Error.to_string e)
115
115
116
116
let test_update_key_preserves_order () =
117
-
let tbl = toml_table [ ("a", V.Int 1L); ("b", V.Int 2L); ("c", V.Int 3L) ] in
117
+
let tbl = toml_table [ ("a", V.int 1L); ("b", V.int 2L); ("c", V.int 3L) ] in
118
118
let double = Toml.map ~dec:(fun i -> i * 2) ~enc:Fun.id Toml.int in
119
119
let c = Toml.update_key "b" double in
120
120
match Toml.Private.of_toml c tbl with
121
121
| Ok result ->
122
122
let expected =
123
-
toml_table [ ("a", V.Int 1L); ("b", V.Int 4L); ("c", V.Int 3L) ]
123
+
toml_table [ ("a", V.int 1L); ("b", V.int 4L); ("c", V.int 3L) ]
124
124
in
125
125
Alcotest.(check toml_t) "update preserves order" expected result
126
126
| Error e ->
127
127
Alcotest.failf "update_key order failed: %s" (Toml.Error.to_string e)
128
128
129
129
let test_update_key_missing () =
130
-
let tbl = toml_table [ ("a", V.Int 1L) ] in
130
+
let tbl = toml_table [ ("a", V.int 1L) ] in
131
131
let c = Toml.update_key "b" Toml.int in
132
132
match Toml.Private.of_toml c tbl with
133
133
| Error _ -> ()
···
135
135
136
136
let test_update_key_not_table () =
137
137
let c = Toml.update_key "x" Toml.string in
138
-
match Toml.Private.of_toml c (V.String "hello") with
138
+
match Toml.Private.of_toml c (V.string "hello") with
139
139
| Error _ -> ()
140
140
| Ok _ -> Alcotest.fail "update_key should error on non-table"
141
141
142
142
let test_update_key_encode_passthrough () =
143
-
let tbl = toml_table [ ("name", V.String "alice"); ("age", V.Int 30L) ] in
143
+
let tbl = toml_table [ ("name", V.string "alice"); ("age", V.int 30L) ] in
144
144
let c = Toml.update_key "name" Toml.string in
145
145
let result = Toml.Private.to_toml c tbl in
146
146
Alcotest.(check toml_t) "update_key encode is identity" tbl result
···
148
148
let test_delete_key () =
149
149
let tbl =
150
150
toml_table
151
-
[ ("name", V.String "alice"); ("age", V.Int 30L); ("debug", V.Bool true) ]
151
+
[ ("name", V.string "alice"); ("age", V.int 30L); ("debug", V.bool true) ]
152
152
in
153
153
let c = Toml.delete_key "debug" in
154
154
match Toml.Private.of_toml c tbl with
155
155
| Ok result ->
156
156
let expected =
157
-
toml_table [ ("name", V.String "alice"); ("age", V.Int 30L) ]
157
+
toml_table [ ("name", V.string "alice"); ("age", V.int 30L) ]
158
158
in
159
159
Alcotest.(check toml_t) "delete_key removes member" expected result
160
160
| Error e -> Alcotest.failf "delete_key failed: %s" (Toml.Error.to_string e)
161
161
162
162
let test_delete_key_missing () =
163
163
(* Deleting a nonexistent key is a no-op *)
164
-
let tbl = toml_table [ ("a", V.Int 1L) ] in
164
+
let tbl = toml_table [ ("a", V.int 1L) ] in
165
165
let c = Toml.delete_key "b" in
166
166
match Toml.Private.of_toml c tbl with
167
167
| Ok result ->
···
171
171
172
172
let test_delete_key_not_table () =
173
173
let c = Toml.delete_key "x" in
174
-
match Toml.Private.of_toml c (V.Int 42L) with
174
+
match Toml.Private.of_toml c (V.int 42L) with
175
175
| Error _ -> ()
176
176
| Ok _ -> Alcotest.fail "delete_key should error on non-table"
177
177
178
178
let test_delete_key_encode_passthrough () =
179
-
let tbl = toml_table [ ("a", V.Int 1L); ("b", V.Int 2L) ] in
179
+
let tbl = toml_table [ ("a", V.int 1L); ("b", V.int 2L) ] in
180
180
let c = Toml.delete_key "a" in
181
181
let result = Toml.Private.to_toml c tbl in
182
182
Alcotest.(check toml_t) "delete_key encode is identity" tbl result
+215
-222
ocaml-toml/test/test_value.ml
+215
-222
ocaml-toml/test/test_value.ml
···
12
12
let parse_toml s =
13
13
match Toml.Parser.of_string s with
14
14
| Ok v -> v
15
-
| Error e -> Alcotest.fail (Error.to_string e)
15
+
| Error e -> Alcotest.fail (Toml.Error.to_string e)
16
16
17
17
let parse_error s =
18
18
match Toml.Parser.of_string s with
19
19
| Ok _ -> Alcotest.fail "Expected parse error"
20
20
| Error _ -> ()
21
21
22
-
(* Custom testable for t *)
23
-
let rec pp_t fmt = function
24
-
| String s -> Fmt.pf fmt "String %S" s
25
-
| Int i -> Fmt.pf fmt "Int %Ld" i
26
-
| Float f -> Fmt.pf fmt "Float %f" f
27
-
| Bool b -> Fmt.pf fmt "Bool %b" b
28
-
| Datetime s -> Fmt.pf fmt "Datetime %S" s
29
-
| Datetime_local s -> Fmt.pf fmt "Datetime_local %S" s
30
-
| Date_local s -> Fmt.pf fmt "Date_local %S" s
31
-
| Time_local s -> Fmt.pf fmt "Time_local %S" s
32
-
| Array items ->
33
-
Fmt.pf fmt "Array [%a]"
34
-
(Format.pp_print_list ~pp_sep:(fun fmt () -> Fmt.pf fmt "; ") pp_t)
35
-
items
36
-
| Table pairs ->
37
-
Fmt.pf fmt "Table [%a]"
38
-
(Format.pp_print_list
39
-
~pp_sep:(fun fmt () -> Fmt.pf fmt "; ")
40
-
(fun fmt (k, v) -> Fmt.pf fmt "(%S, %a)" k pp_t v))
41
-
pairs
42
-
43
-
let rec equal_t a b =
44
-
match (a, b) with
45
-
| String s1, String s2 -> String.equal s1 s2
46
-
| Int i1, Int i2 -> Int64.equal i1 i2
47
-
| Float f1, Float f2 ->
48
-
Float.equal f1 f2 || (Float.is_nan f1 && Float.is_nan f2)
49
-
| Bool b1, Bool b2 -> Bool.equal b1 b2
50
-
| Datetime s1, Datetime s2 -> String.equal s1 s2
51
-
| Datetime_local s1, Datetime_local s2 -> String.equal s1 s2
52
-
| Date_local s1, Date_local s2 -> String.equal s1 s2
53
-
| Time_local s1, Time_local s2 -> String.equal s1 s2
54
-
| Array a1, Array a2 ->
55
-
List.length a1 = List.length a2 && List.for_all2 equal_t a1 a2
56
-
| Table p1, Table p2 ->
57
-
List.length p1 = List.length p2
58
-
&& List.for_all2
59
-
(fun (k1, v1) (k2, v2) -> String.equal k1 k2 && equal_t v1 v2)
60
-
(List.sort Stdlib.compare p1)
61
-
(List.sort Stdlib.compare p2)
62
-
| _ -> false
63
-
64
-
let value_testable = Alcotest.testable pp_t equal_t
22
+
(* Custom testable for t: delegate to the library (meta-agnostic). *)
23
+
let value_testable = Alcotest.testable Toml.Value.pp Toml.Value.equal
65
24
66
25
(* Helper to get a key from a table *)
67
-
let get key = function
68
-
| Table pairs -> List.assoc key pairs
69
-
| _ -> Alcotest.fail "Expected table"
26
+
let get key v =
27
+
match Toml.Value.opt key v with
28
+
| Some x -> x
29
+
| None -> Alcotest.fail ("Expected table with key " ^ key)
30
+
31
+
(* Helper to look up a raw (name * t) list (as used after destructuring a Table
32
+
pattern). Replaces List.assoc because keys are now [string node]. *)
33
+
let assoc_pairs key pairs =
34
+
match List.find_opt (fun ((k, _), _) -> String.equal k key) pairs with
35
+
| Some (_, v) -> v
36
+
| None -> raise Not_found
70
37
71
38
(* ============================================
72
39
Comments
···
75
42
let test_comment_full_line () =
76
43
let t = parse_toml "# This is a comment\nkey = \"value\"" in
77
44
Alcotest.(check value_testable)
78
-
"full line comment" (String "value") (get "key" t)
45
+
"full line comment" (string "value") (get "key" t)
79
46
80
47
let test_comment_inline () =
81
48
let t = parse_toml "key = \"value\" # inline comment" in
82
49
Alcotest.(check value_testable)
83
-
"inline comment" (String "value") (get "key" t)
50
+
"inline comment" (string "value") (get "key" t)
84
51
85
52
let test_comment_hash_in_string () =
86
53
let t = parse_toml "key = \"# not a comment\"" in
87
54
Alcotest.(check value_testable)
88
-
"hash in string" (String "# not a comment") (get "key" t)
55
+
"hash in string" (string "# not a comment") (get "key" t)
89
56
90
57
let test_comment_empty () =
91
58
let t = parse_toml "#\nkey = 1" in
92
-
Alcotest.(check value_testable) "empty comment" (Int 1L) (get "key" t)
59
+
Alcotest.(check value_testable) "empty comment" (int 1L) (get "key" t)
93
60
94
61
let comment_tests =
95
62
[
···
106
73
let test_bare_key () =
107
74
let t = parse_toml "key = \"value\"" in
108
75
Alcotest.(check value_testable)
109
-
"simple bare key" (String "value") (get "key" t)
76
+
"simple bare key" (string "value") (get "key" t)
110
77
111
78
let test_bare_key_underscore () =
112
79
let t = parse_toml "bare_key = \"value\"" in
113
80
Alcotest.(check value_testable)
114
-
"bare key with underscore" (String "value") (get "bare_key" t)
81
+
"bare key with underscore" (string "value") (get "bare_key" t)
115
82
116
83
let test_bare_key_dash () =
117
84
let t = parse_toml "bare-key = \"value\"" in
118
85
Alcotest.(check value_testable)
119
-
"bare key with dash" (String "value") (get "bare-key" t)
86
+
"bare key with dash" (string "value") (get "bare-key" t)
120
87
121
88
let test_bare_key_numeric () =
122
89
let t = parse_toml "1234 = \"value\"" in
123
90
Alcotest.(check value_testable)
124
-
"numeric bare key" (String "value") (get "1234" t)
91
+
"numeric bare key" (string "value") (get "1234" t)
125
92
126
93
let test_quoted_key_basic () =
127
94
let t = parse_toml "\"127.0.0.1\" = \"value\"" in
128
95
Alcotest.(check value_testable)
129
-
"quoted key with dots" (String "value") (get "127.0.0.1" t)
96
+
"quoted key with dots" (string "value") (get "127.0.0.1" t)
130
97
131
98
let test_quoted_key_spaces () =
132
99
let t = parse_toml "\"character encoding\" = \"value\"" in
133
100
Alcotest.(check value_testable)
134
-
"quoted key with spaces" (String "value")
101
+
"quoted key with spaces" (string "value")
135
102
(get "character encoding" t)
136
103
137
104
let test_quoted_key_literal () =
138
105
let t = parse_toml "'key' = \"value\"" in
139
106
Alcotest.(check value_testable)
140
-
"literal quoted key" (String "value") (get "key" t)
107
+
"literal quoted key" (string "value") (get "key" t)
141
108
142
109
let test_empty_quoted_key () =
143
110
let t = parse_toml "\"\" = \"blank\"" in
144
-
Alcotest.(check value_testable) "empty quoted key" (String "blank") (get "" t)
111
+
Alcotest.(check value_testable) "empty quoted key" (string "blank") (get "" t)
145
112
146
113
let test_dotted_key () =
147
114
let t = parse_toml "physical.color = \"orange\"" in
148
-
match get "physical" t with
149
-
| Table pairs ->
150
-
Alcotest.(check value_testable)
151
-
"dotted key" (String "orange") (List.assoc "color" pairs)
152
-
| _ -> Alcotest.fail "Expected nested table"
115
+
Alcotest.(check value_testable)
116
+
"dotted key" (string "orange")
117
+
(get "color" (get "physical" t))
153
118
154
119
let test_dotted_key_quoted () =
155
120
let t = parse_toml "site.\"google.com\" = true" in
156
-
match get "site" t with
157
-
| Table pairs ->
158
-
Alcotest.(check value_testable)
159
-
"dotted key with quoted part" (Bool true)
160
-
(List.assoc "google.com" pairs)
161
-
| _ -> Alcotest.fail "Expected nested table"
121
+
Alcotest.(check value_testable)
122
+
"dotted key with quoted part" (bool true)
123
+
(get "google.com" (get "site" t))
162
124
163
125
let test_dotted_key_whitespace () =
164
126
let t = parse_toml "fruit . color = \"yellow\"" in
165
-
match get "fruit" t with
166
-
| Table pairs ->
167
-
Alcotest.(check value_testable)
168
-
"dotted key with whitespace" (String "yellow")
169
-
(List.assoc "color" pairs)
170
-
| _ -> Alcotest.fail "Expected nested table"
127
+
Alcotest.(check value_testable)
128
+
"dotted key with whitespace" (string "yellow")
129
+
(get "color" (get "fruit" t))
171
130
172
131
let test_duplicate_key_error () =
173
132
parse_error "name = \"Tom\"\nname = \"Pradyun\""
···
199
158
let test_basic_string () =
200
159
let t = parse_toml {|str = "hello world"|} in
201
160
Alcotest.(check value_testable)
202
-
"basic string" (String "hello world") (get "str" t)
161
+
"basic string" (string "hello world") (get "str" t)
203
162
204
163
let test_basic_string_escapes () =
205
164
let t = parse_toml {|str = "tab\there"|} in
206
165
Alcotest.(check value_testable)
207
-
"tab escape" (String "tab\there") (get "str" t)
166
+
"tab escape" (string "tab\there") (get "str" t)
208
167
209
168
let test_basic_string_newline () =
210
169
let t = parse_toml {|str = "line1\nline2"|} in
211
170
Alcotest.(check value_testable)
212
-
"newline escape" (String "line1\nline2") (get "str" t)
171
+
"newline escape" (string "line1\nline2") (get "str" t)
213
172
214
173
let test_basic_string_backslash () =
215
174
let t = parse_toml {|str = "back\\slash"|} in
216
175
Alcotest.(check value_testable)
217
-
"backslash escape" (String "back\\slash") (get "str" t)
176
+
"backslash escape" (string "back\\slash") (get "str" t)
218
177
219
178
let test_basic_string_quote () =
220
179
let t = parse_toml {|str = "say \"hello\""|} in
221
180
Alcotest.(check value_testable)
222
-
"quote escape" (String "say \"hello\"") (get "str" t)
181
+
"quote escape" (string "say \"hello\"") (get "str" t)
223
182
224
183
let test_basic_string_unicode_u () =
225
184
let t = parse_toml {|str = "\u0041"|} in
226
185
Alcotest.(check value_testable)
227
-
"unicode \\u escape" (String "A") (get "str" t)
186
+
"unicode \\u escape" (string "A") (get "str" t)
228
187
229
188
let test_basic_string_unicode_U () =
230
189
let t = parse_toml {|str = "\U0001F600"|} in
231
190
(* U+1F600 is the grinning face emoji *)
232
191
Alcotest.(check value_testable)
233
-
"unicode \\U escape" (String "\xF0\x9F\x98\x80") (get "str" t)
192
+
"unicode \\U escape"
193
+
(string "\xF0\x9F\x98\x80")
194
+
(get "str" t)
234
195
235
196
let test_basic_string_hex_escape () =
236
197
let t = parse_toml {|str = "\xE9"|} in
237
198
(* U+00E9 is e-acute *)
238
-
Alcotest.(check value_testable) "hex escape" (String "\xC3\xA9") (get "str" t)
199
+
Alcotest.(check value_testable) "hex escape" (string "\xC3\xA9") (get "str" t)
239
200
240
201
let test_basic_string_escape_e () =
241
202
let t = parse_toml {|str = "\e"|} in
242
-
Alcotest.(check value_testable) "escape \\e" (String "\x1B") (get "str" t)
203
+
Alcotest.(check value_testable) "escape \\e" (string "\x1B") (get "str" t)
243
204
244
205
let test_literal_string () =
245
206
let t = parse_toml {|str = 'C:\Users\nodejs\templates'|} in
246
207
Alcotest.(check value_testable)
247
-
"literal string" (String {|C:\Users\nodejs\templates|}) (get "str" t)
208
+
"literal string"
209
+
(string {|C:\Users\nodejs\templates|})
210
+
(get "str" t)
248
211
249
212
let test_literal_string_no_escape () =
250
213
let t = parse_toml {|str = '<\i\c*\s*>'|} in
251
214
Alcotest.(check value_testable)
252
-
"literal no escape" (String {|<\i\c*\s*>|}) (get "str" t)
215
+
"literal no escape" (string {|<\i\c*\s*>|}) (get "str" t)
253
216
254
217
let test_multiline_basic () =
255
218
let t = parse_toml {|str = """
256
219
Roses are red
257
220
Violets are blue"""|} in
258
221
Alcotest.(check value_testable)
259
-
"multiline basic" (String "Roses are red\nViolets are blue") (get "str" t)
222
+
"multiline basic"
223
+
(string "Roses are red\nViolets are blue")
224
+
(get "str" t)
260
225
261
226
let test_multiline_basic_trim () =
262
227
let t =
···
268
233
"""|}
269
234
in
270
235
Alcotest.(check value_testable)
271
-
"multiline trim" (String "The quick brown fox jumps over the lazy dog.")
236
+
"multiline trim"
237
+
(string "The quick brown fox jumps over the lazy dog.")
272
238
(get "str" t)
273
239
274
240
let test_multiline_basic_quotes () =
···
277
243
in
278
244
Alcotest.(check value_testable)
279
245
"multiline with quotes"
280
-
(String {|Here are two quotation marks: "". Simple.|}) (get "str" t)
246
+
(string {|Here are two quotation marks: "". Simple.|})
247
+
(get "str" t)
281
248
282
249
let test_multiline_literal () =
283
250
let t =
···
296
263
\ is preserved.\n"
297
264
in
298
265
Alcotest.(check value_testable)
299
-
"multiline literal" (String expected) (get "str" t)
266
+
"multiline literal" (string expected) (get "str" t)
300
267
301
268
let test_multiline_literal_no_escape () =
302
269
let t = parse_toml {|str = '''I [dw]on't need \d{2} apples'''|} in
303
270
Alcotest.(check value_testable)
304
-
"multiline literal no escape" (String {|I [dw]on't need \d{2} apples|})
271
+
"multiline literal no escape"
272
+
(string {|I [dw]on't need \d{2} apples|})
305
273
(get "str" t)
306
274
307
275
let string_tests =
···
330
298
331
299
let test_integer_positive () =
332
300
let t = parse_toml "int = +99" in
333
-
Alcotest.(check value_testable) "positive integer" (Int 99L) (get "int" t)
301
+
Alcotest.(check value_testable) "positive integer" (int 99L) (get "int" t)
334
302
335
303
let test_integer_plain () =
336
304
let t = parse_toml "int = 42" in
337
-
Alcotest.(check value_testable) "plain integer" (Int 42L) (get "int" t)
305
+
Alcotest.(check value_testable) "plain integer" (int 42L) (get "int" t)
338
306
339
307
let test_integer_zero () =
340
308
let t = parse_toml "int = 0" in
341
-
Alcotest.(check value_testable) "zero" (Int 0L) (get "int" t)
309
+
Alcotest.(check value_testable) "zero" (int 0L) (get "int" t)
342
310
343
311
let test_integer_negative () =
344
312
let t = parse_toml "int = -17" in
345
-
Alcotest.(check value_testable) "negative integer" (Int (-17L)) (get "int" t)
313
+
Alcotest.(check value_testable) "negative integer" (int (-17L)) (get "int" t)
346
314
347
315
let test_integer_underscore () =
348
316
let t = parse_toml "int = 1_000" in
349
317
Alcotest.(check value_testable)
350
-
"underscore separator" (Int 1000L) (get "int" t)
318
+
"underscore separator" (int 1000L) (get "int" t)
351
319
352
320
let test_integer_underscore_multi () =
353
321
let t = parse_toml "int = 5_349_221" in
354
322
Alcotest.(check value_testable)
355
-
"multiple underscores" (Int 5349221L) (get "int" t)
323
+
"multiple underscores" (int 5349221L) (get "int" t)
356
324
357
325
let test_integer_hex () =
358
326
let t = parse_toml "int = 0xDEADBEEF" in
359
-
Alcotest.(check value_testable) "hexadecimal" (Int 0xDEADBEEFL) (get "int" t)
327
+
Alcotest.(check value_testable) "hexadecimal" (int 0xDEADBEEFL) (get "int" t)
360
328
361
329
let test_integer_hex_lower () =
362
330
let t = parse_toml "int = 0xdeadbeef" in
363
331
Alcotest.(check value_testable)
364
-
"hex lowercase" (Int 0xdeadbeefL) (get "int" t)
332
+
"hex lowercase" (int 0xdeadbeefL) (get "int" t)
365
333
366
334
let test_integer_hex_underscore () =
367
335
let t = parse_toml "int = 0xdead_beef" in
368
336
Alcotest.(check value_testable)
369
-
"hex with underscore" (Int 0xdeadbeefL) (get "int" t)
337
+
"hex with underscore" (int 0xdeadbeefL) (get "int" t)
370
338
371
339
let test_integer_octal () =
372
340
let t = parse_toml "int = 0o755" in
373
-
Alcotest.(check value_testable) "octal" (Int 0o755L) (get "int" t)
341
+
Alcotest.(check value_testable) "octal" (int 0o755L) (get "int" t)
374
342
375
343
let test_integer_binary () =
376
344
let t = parse_toml "int = 0b11010110" in
377
-
Alcotest.(check value_testable) "binary" (Int 0b11010110L) (get "int" t)
345
+
Alcotest.(check value_testable) "binary" (int 0b11010110L) (get "int" t)
378
346
379
347
let test_integer_leading_zero_error () = parse_error "int = 007"
380
348
381
349
let test_integer_large () =
382
350
let t = parse_toml "int = 9223372036854775807" in
383
-
Alcotest.(check value_testable) "max int64" (Int Int64.max_int) (get "int" t)
351
+
Alcotest.(check value_testable) "max int64" (int Int64.max_int) (get "int" t)
384
352
385
353
let test_integer_negative_large () =
386
354
let t = parse_toml "int = -9223372036854775808" in
387
-
Alcotest.(check value_testable) "min int64" (Int Int64.min_int) (get "int" t)
355
+
Alcotest.(check value_testable) "min int64" (int Int64.min_int) (get "int" t)
388
356
389
357
let integer_tests =
390
358
[
···
410
378
411
379
let test_float_positive () =
412
380
let t = parse_toml "flt = +1.0" in
413
-
Alcotest.(check value_testable) "positive float" (Float 1.0) (get "flt" t)
381
+
Alcotest.(check value_testable) "positive float" (float 1.0) (get "flt" t)
414
382
415
383
let test_float_fractional () =
416
384
let t = parse_toml "flt = 3.1415" in
417
-
Alcotest.(check value_testable) "fractional" (Float 3.1415) (get "flt" t)
385
+
Alcotest.(check value_testable) "fractional" (float 3.1415) (get "flt" t)
418
386
419
387
let test_float_negative () =
420
388
let t = parse_toml "flt = -0.01" in
421
-
Alcotest.(check value_testable) "negative float" (Float (-0.01)) (get "flt" t)
389
+
Alcotest.(check value_testable) "negative float" (float (-0.01)) (get "flt" t)
422
390
423
391
let test_float_exponent () =
424
392
let t = parse_toml "flt = 5e+22" in
425
-
Alcotest.(check value_testable) "exponent" (Float 5e+22) (get "flt" t)
393
+
Alcotest.(check value_testable) "exponent" (float 5e+22) (get "flt" t)
426
394
427
395
let test_float_exponent_no_sign () =
428
396
let t = parse_toml "flt = 1e06" in
429
-
Alcotest.(check value_testable) "exponent no sign" (Float 1e06) (get "flt" t)
397
+
Alcotest.(check value_testable) "exponent no sign" (float 1e06) (get "flt" t)
430
398
431
399
let test_float_exponent_negative () =
432
400
let t = parse_toml "flt = -2E-2" in
433
401
Alcotest.(check value_testable)
434
-
"negative exponent" (Float (-2E-2)) (get "flt" t)
402
+
"negative exponent" (float (-2E-2)) (get "flt" t)
435
403
436
404
let test_float_both () =
437
405
let t = parse_toml "flt = 6.626e-34" in
438
406
Alcotest.(check value_testable)
439
-
"fractional and exponent" (Float 6.626e-34) (get "flt" t)
407
+
"fractional and exponent" (float 6.626e-34) (get "flt" t)
440
408
441
409
let test_float_underscore () =
442
410
let t = parse_toml "flt = 224_617.445_991_228" in
443
411
Alcotest.(check value_testable)
444
-
"underscore in float" (Float 224617.445991228) (get "flt" t)
412
+
"underscore in float" (float 224617.445991228) (get "flt" t)
445
413
446
414
let test_float_inf () =
447
415
let t = parse_toml "flt = inf" in
448
416
Alcotest.(check value_testable)
449
-
"infinity" (Float Float.infinity) (get "flt" t)
417
+
"infinity" (float Float.infinity) (get "flt" t)
450
418
451
419
let test_float_pos_inf () =
452
420
let t = parse_toml "flt = +inf" in
453
421
Alcotest.(check value_testable)
454
-
"positive infinity" (Float Float.infinity) (get "flt" t)
422
+
"positive infinity" (float Float.infinity) (get "flt" t)
455
423
456
424
let test_float_neg_inf () =
457
425
let t = parse_toml "flt = -inf" in
458
426
Alcotest.(check value_testable)
459
-
"negative infinity" (Float Float.neg_infinity) (get "flt" t)
427
+
"negative infinity" (float Float.neg_infinity) (get "flt" t)
460
428
461
429
let test_float_nan () =
462
430
let t = parse_toml "flt = nan" in
463
431
match get "flt" t with
464
-
| Float f when Float.is_nan f -> ()
432
+
| Float (f, _) when Float.is_nan f -> ()
465
433
| _ -> Alcotest.fail "Expected NaN"
466
434
467
435
let test_float_pos_nan () =
468
436
let t = parse_toml "flt = +nan" in
469
437
match get "flt" t with
470
-
| Float f when Float.is_nan f -> ()
438
+
| Float (f, _) when Float.is_nan f -> ()
471
439
| _ -> Alcotest.fail "Expected NaN"
472
440
473
441
let test_float_neg_nan () =
474
442
let t = parse_toml "flt = -nan" in
475
443
match get "flt" t with
476
-
| Float f when Float.is_nan f -> ()
444
+
| Float (f, _) when Float.is_nan f -> ()
477
445
| _ -> Alcotest.fail "Expected NaN"
478
446
479
447
let test_float_no_leading_digit () = parse_error "flt = .7"
···
505
473
506
474
let test_bool_true () =
507
475
let t = parse_toml "bool = true" in
508
-
Alcotest.(check value_testable) "true" (Bool true) (get "bool" t)
476
+
Alcotest.(check value_testable) "true" (bool true) (get "bool" t)
509
477
510
478
let test_bool_false () =
511
479
let t = parse_toml "bool = false" in
512
-
Alcotest.(check value_testable) "false" (Bool false) (get "bool" t)
480
+
Alcotest.(check value_testable) "false" (bool false) (get "bool" t)
513
481
514
482
let test_bool_case_sensitive () = parse_error "bool = True"
515
483
···
527
495
let test_datetime_offset () =
528
496
let t = parse_toml "dt = 1979-05-27T07:32:00Z" in
529
497
Alcotest.(check value_testable)
530
-
"offset datetime UTC" (Datetime "1979-05-27T07:32:00Z") (get "dt" t)
498
+
"offset datetime UTC"
499
+
(datetime "1979-05-27T07:32:00Z")
500
+
(get "dt" t)
531
501
532
502
let test_datetime_offset_negative () =
533
503
let t = parse_toml "dt = 1979-05-27T00:32:00-07:00" in
534
504
Alcotest.(check value_testable)
535
-
"offset datetime negative" (Datetime "1979-05-27T00:32:00-07:00")
505
+
"offset datetime negative"
506
+
(datetime "1979-05-27T00:32:00-07:00")
536
507
(get "dt" t)
537
508
538
509
let test_datetime_offset_frac () =
539
510
let t = parse_toml "dt = 1979-05-27T00:32:00.5-07:00" in
540
511
Alcotest.(check value_testable)
541
-
"offset datetime fractional" (Datetime "1979-05-27T00:32:00.5-07:00")
512
+
"offset datetime fractional"
513
+
(datetime "1979-05-27T00:32:00.5-07:00")
542
514
(get "dt" t)
543
515
544
516
let test_datetime_space_separator () =
545
517
let t = parse_toml "dt = 1979-05-27 07:32:00Z" in
546
518
Alcotest.(check value_testable)
547
-
"space separator" (Datetime "1979-05-27T07:32:00Z") (get "dt" t)
519
+
"space separator"
520
+
(datetime "1979-05-27T07:32:00Z")
521
+
(get "dt" t)
548
522
549
523
let test_datetime_local () =
550
524
let t = parse_toml "dt = 1979-05-27T07:32:00" in
551
525
Alcotest.(check value_testable)
552
-
"local datetime" (Datetime_local "1979-05-27T07:32:00") (get "dt" t)
526
+
"local datetime"
527
+
(datetime_local "1979-05-27T07:32:00")
528
+
(get "dt" t)
553
529
554
530
let test_datetime_local_frac () =
555
531
let t = parse_toml "dt = 1979-05-27T07:32:00.5" in
556
532
Alcotest.(check value_testable)
557
-
"local datetime fractional" (Datetime_local "1979-05-27T07:32:00.5")
533
+
"local datetime fractional"
534
+
(datetime_local "1979-05-27T07:32:00.5")
558
535
(get "dt" t)
559
536
560
537
let test_date_local () =
561
538
let t = parse_toml "dt = 1979-05-27" in
562
539
Alcotest.(check value_testable)
563
-
"local date" (Date_local "1979-05-27") (get "dt" t)
540
+
"local date" (date_local "1979-05-27") (get "dt" t)
564
541
565
542
let test_time_local () =
566
543
let t = parse_toml "dt = 07:32:00" in
567
544
Alcotest.(check value_testable)
568
-
"local time" (Time_local "07:32:00") (get "dt" t)
545
+
"local time" (time_local "07:32:00") (get "dt" t)
569
546
570
547
let test_time_local_frac () =
571
548
let t = parse_toml "dt = 00:32:00.999999" in
572
549
Alcotest.(check value_testable)
573
-
"local time fractional" (Time_local "00:32:00.999999") (get "dt" t)
550
+
"local time fractional"
551
+
(time_local "00:32:00.999999")
552
+
(get "dt" t)
574
553
575
554
let datetime_tests =
576
555
[
···
593
572
let t = parse_toml "arr = [1, 2, 3]" in
594
573
Alcotest.(check value_testable)
595
574
"integer array"
596
-
(Array [ Int 1L; Int 2L; Int 3L ])
575
+
(array [ int 1L; int 2L; int 3L ])
597
576
(get "arr" t)
598
577
599
578
let test_array_strings () =
600
579
let t = parse_toml {|arr = ["red", "yellow", "green"]|} in
601
580
Alcotest.(check value_testable)
602
581
"string array"
603
-
(Array [ String "red"; String "yellow"; String "green" ])
582
+
(array [ string "red"; string "yellow"; string "green" ])
604
583
(get "arr" t)
605
584
606
585
let test_array_nested () =
607
586
let t = parse_toml "arr = [[1, 2], [3, 4, 5]]" in
608
587
Alcotest.(check value_testable)
609
588
"nested array"
610
-
(Array [ Array [ Int 1L; Int 2L ]; Array [ Int 3L; Int 4L; Int 5L ] ])
589
+
(array [ array [ int 1L; int 2L ]; array [ int 3L; int 4L; int 5L ] ])
611
590
(get "arr" t)
612
591
613
592
let test_array_mixed () =
614
593
let t = parse_toml "arr = [0.1, 0.2, 1, 2]" in
615
594
Alcotest.(check value_testable)
616
595
"mixed types"
617
-
(Array [ Float 0.1; Float 0.2; Int 1L; Int 2L ])
596
+
(array [ float 0.1; float 0.2; int 1L; int 2L ])
618
597
(get "arr" t)
619
598
620
599
let test_array_empty () =
621
600
let t = parse_toml "arr = []" in
622
-
Alcotest.(check value_testable) "empty array" (Array []) (get "arr" t)
601
+
Alcotest.(check value_testable) "empty array" (array []) (get "arr" t)
623
602
624
603
let test_array_multiline () =
625
604
let t = parse_toml "arr = [\n 1,\n 2,\n 3\n]" in
626
605
Alcotest.(check value_testable)
627
606
"multiline array"
628
-
(Array [ Int 1L; Int 2L; Int 3L ])
607
+
(array [ int 1L; int 2L; int 3L ])
629
608
(get "arr" t)
630
609
631
610
let test_array_trailing_comma () =
632
611
let t = parse_toml "arr = [1, 2, 3,]" in
633
612
Alcotest.(check value_testable)
634
613
"trailing comma"
635
-
(Array [ Int 1L; Int 2L; Int 3L ])
614
+
(array [ int 1L; int 2L; int 3L ])
636
615
(get "arr" t)
637
616
638
617
let test_array_with_inline_tables () =
639
618
let t = parse_toml {|arr = [{x = 1}, {x = 2}]|} in
640
619
match get "arr" t with
641
-
| Array [ Table [ ("x", Int 1L) ]; Table [ ("x", Int 2L) ] ] -> ()
620
+
| Array
621
+
( [
622
+
Table ([ (("x", _), Int (1L, _)) ], _);
623
+
Table ([ (("x", _), Int (2L, _)) ], _);
624
+
],
625
+
_ ) ->
626
+
()
642
627
| _ -> Alcotest.fail "Expected array of inline tables"
643
628
644
629
let array_tests =
···
660
645
let test_table_basic () =
661
646
let t = parse_toml "[table]\nkey = \"value\"" in
662
647
match get "table" t with
663
-
| Table pairs ->
648
+
| Table (pairs, _) ->
664
649
Alcotest.(check value_testable)
665
-
"basic table" (String "value") (List.assoc "key" pairs)
650
+
"basic table" (string "value") (assoc_pairs "key" pairs)
666
651
| _ -> Alcotest.fail "Expected table"
667
652
668
653
let test_table_multiple () =
669
654
let t = parse_toml "[table1]\nkey1 = 1\n\n[table2]\nkey2 = 2" in
670
655
let t1 = get "table1" t and t2 = get "table2" t in
671
656
(match t1 with
672
-
| Table pairs ->
657
+
| Table (pairs, _) ->
673
658
Alcotest.(check value_testable)
674
-
"table1" (Int 1L) (List.assoc "key1" pairs)
659
+
"table1" (int 1L) (assoc_pairs "key1" pairs)
675
660
| _ -> Alcotest.fail "Expected table1");
676
661
match t2 with
677
-
| Table pairs ->
662
+
| Table (pairs, _) ->
678
663
Alcotest.(check value_testable)
679
-
"table2" (Int 2L) (List.assoc "key2" pairs)
664
+
"table2" (int 2L) (assoc_pairs "key2" pairs)
680
665
| _ -> Alcotest.fail "Expected table2"
681
666
682
667
let test_table_dotted_header () =
683
668
let t = parse_toml "[dog.\"tater.man\"]\ntype = \"pug\"" in
684
669
match get "dog" t with
685
-
| Table pairs -> (
686
-
match List.assoc "tater.man" pairs with
687
-
| Table inner ->
670
+
| Table (pairs, _) -> (
671
+
match assoc_pairs "tater.man" pairs with
672
+
| Table (inner, _) ->
688
673
Alcotest.(check value_testable)
689
-
"nested quoted" (String "pug") (List.assoc "type" inner)
674
+
"nested quoted" (string "pug") (assoc_pairs "type" inner)
690
675
| _ -> Alcotest.fail "Expected nested table")
691
676
| _ -> Alcotest.fail "Expected dog table"
692
677
···
700
685
let test_table_empty () =
701
686
let t = parse_toml "[empty]\n[other]\nkey = 1" in
702
687
match get "empty" t with
703
-
| Table [] -> ()
688
+
| Table ([], _) -> ()
704
689
| Table _ -> () (* May have implicit content *)
705
690
| _ -> Alcotest.fail "Expected empty table"
706
691
···
710
695
let test_table_super_after () =
711
696
let t = parse_toml "[x.y]\na = 1\n[x]\nb = 2" in
712
697
match get "x" t with
713
-
| Table pairs ->
698
+
| Table (pairs, _) ->
714
699
Alcotest.(check value_testable)
715
-
"super table b" (Int 2L) (List.assoc "b" pairs)
700
+
"super table b" (int 2L) (assoc_pairs "b" pairs)
716
701
| _ -> Alcotest.fail "Expected x table"
717
702
718
703
let table_tests =
···
733
718
let test_inline_table_basic () =
734
719
let t = parse_toml {|name = { first = "Tom", last = "Preston-Werner" }|} in
735
720
match get "name" t with
736
-
| Table pairs ->
721
+
| Table (pairs, _) ->
737
722
Alcotest.(check value_testable)
738
-
"first" (String "Tom") (List.assoc "first" pairs);
723
+
"first" (string "Tom")
724
+
(assoc_pairs "first" pairs);
739
725
Alcotest.(check value_testable)
740
-
"last" (String "Preston-Werner") (List.assoc "last" pairs)
726
+
"last" (string "Preston-Werner") (assoc_pairs "last" pairs)
741
727
| _ -> Alcotest.fail "Expected inline table"
742
728
743
729
let test_inline_table_compact () =
744
730
let t = parse_toml "point = {x=1, y=2}" in
745
731
match get "point" t with
746
-
| Table pairs ->
747
-
Alcotest.(check value_testable) "x" (Int 1L) (List.assoc "x" pairs);
748
-
Alcotest.(check value_testable) "y" (Int 2L) (List.assoc "y" pairs)
732
+
| Table (pairs, _) ->
733
+
Alcotest.(check value_testable) "x" (int 1L) (assoc_pairs "x" pairs);
734
+
Alcotest.(check value_testable) "y" (int 2L) (assoc_pairs "y" pairs)
749
735
| _ -> Alcotest.fail "Expected inline table"
750
736
751
737
let test_inline_table_dotted_key () =
752
738
let t = parse_toml "animal = { type.name = \"pug\" }" in
753
739
match get "animal" t with
754
-
| Table pairs -> (
755
-
match List.assoc "type" pairs with
756
-
| Table inner ->
740
+
| Table (pairs, _) -> (
741
+
match assoc_pairs "type" pairs with
742
+
| Table (inner, _) ->
757
743
Alcotest.(check value_testable)
758
-
"nested" (String "pug") (List.assoc "name" inner)
744
+
"nested" (string "pug") (assoc_pairs "name" inner)
759
745
| _ -> Alcotest.fail "Expected type table")
760
746
| _ -> Alcotest.fail "Expected animal table"
761
747
762
748
let test_inline_table_empty () =
763
749
let t = parse_toml "empty = {}" in
764
750
Alcotest.(check value_testable)
765
-
"empty inline table" (Table []) (get "empty" t)
751
+
"empty inline table" (table []) (get "empty" t)
766
752
767
753
let test_inline_table_trailing_comma () =
768
754
let t = parse_toml "x = {a = 1, b = 2,}" in
769
755
match get "x" t with
770
-
| Table pairs ->
771
-
Alcotest.(check value_testable) "a" (Int 1L) (List.assoc "a" pairs);
772
-
Alcotest.(check value_testable) "b" (Int 2L) (List.assoc "b" pairs)
756
+
| Table (pairs, _) ->
757
+
Alcotest.(check value_testable) "a" (int 1L) (assoc_pairs "a" pairs);
758
+
Alcotest.(check value_testable) "b" (int 2L) (assoc_pairs "b" pairs)
773
759
| _ -> Alcotest.fail "Expected inline table"
774
760
775
761
let test_inline_table_nested () =
776
762
let t = parse_toml "x = { a = { b = 1 } }" in
777
763
match get "x" t with
778
-
| Table pairs -> (
779
-
match List.assoc "a" pairs with
780
-
| Table inner ->
764
+
| Table (pairs, _) -> (
765
+
match assoc_pairs "a" pairs with
766
+
| Table (inner, _) ->
781
767
Alcotest.(check value_testable)
782
-
"nested" (Int 1L) (List.assoc "b" inner)
768
+
"nested" (int 1L) (assoc_pairs "b" inner)
783
769
| _ -> Alcotest.fail "Expected nested table")
784
770
| _ -> Alcotest.fail "Expected x table"
785
771
···
794
780
]
795
781
796
782
(* ============================================
797
-
Array of Tables
783
+
array of Tables
798
784
============================================ *)
799
785
800
786
let test_array_of_tables_basic () =
···
802
788
parse_toml "[[product]]\nname = \"Hammer\"\n\n[[product]]\nname = \"Nail\""
803
789
in
804
790
match get "product" t with
805
-
| Array [ Table p1; Table p2 ] ->
791
+
| Array ([ Table (p1, _); Table (p2, _) ], _) ->
806
792
Alcotest.(check value_testable)
807
-
"first" (String "Hammer") (List.assoc "name" p1);
793
+
"first" (string "Hammer") (assoc_pairs "name" p1);
808
794
Alcotest.(check value_testable)
809
-
"second" (String "Nail") (List.assoc "name" p2)
795
+
"second" (string "Nail") (assoc_pairs "name" p2)
810
796
| _ -> Alcotest.fail "Expected array of tables"
811
797
812
798
let test_array_of_tables_empty () =
···
819
805
name = \"Nail\""
820
806
in
821
807
match get "product" t with
822
-
| Array [ _; Table []; _ ] -> ()
823
-
| Array items when List.length items = 3 -> ()
808
+
| Array ([ _; Table ([], _); _ ], _) -> ()
809
+
| Array (items, _) when List.length items = 3 -> ()
824
810
| _ -> Alcotest.fail "Expected 3 elements"
825
811
826
812
let test_array_of_tables_subtable () =
···
829
815
"[[fruits]]\nname = \"apple\"\n\n[fruits.physical]\ncolor = \"red\""
830
816
in
831
817
match get "fruits" t with
832
-
| Array [ Table pairs ] -> (
818
+
| Array ([ Table (pairs, _) ], _) -> (
833
819
Alcotest.(check value_testable)
834
-
"name" (String "apple") (List.assoc "name" pairs);
835
-
match List.assoc "physical" pairs with
836
-
| Table inner ->
820
+
"name" (string "apple") (assoc_pairs "name" pairs);
821
+
match assoc_pairs "physical" pairs with
822
+
| Table (inner, _) ->
837
823
Alcotest.(check value_testable)
838
-
"color" (String "red") (List.assoc "color" inner)
824
+
"color" (string "red")
825
+
(assoc_pairs "color" inner)
839
826
| _ -> Alcotest.fail "Expected physical table")
840
827
| _ -> Alcotest.fail "Expected array of tables"
841
828
···
850
837
name = \"granny smith\""
851
838
in
852
839
match get "fruits" t with
853
-
| Array [ Table pairs ] -> (
840
+
| Array ([ Table (pairs, _) ], _) -> (
854
841
Alcotest.(check value_testable)
855
-
"name" (String "apple") (List.assoc "name" pairs);
856
-
match List.assoc "varieties" pairs with
857
-
| Array [ Table v1; Table v2 ] ->
842
+
"name" (string "apple") (assoc_pairs "name" pairs);
843
+
match assoc_pairs "varieties" pairs with
844
+
| Array ([ Table (v1, _); Table (v2, _) ], _) ->
858
845
Alcotest.(check value_testable)
859
-
"v1" (String "red delicious") (List.assoc "name" v1);
846
+
"v1" (string "red delicious") (assoc_pairs "name" v1);
860
847
Alcotest.(check value_testable)
861
-
"v2" (String "granny smith") (List.assoc "name" v2)
848
+
"v2" (string "granny smith") (assoc_pairs "name" v2)
862
849
| _ -> Alcotest.fail "Expected varieties array")
863
850
| _ -> Alcotest.fail "Expected fruits array"
864
851
···
879
866
880
867
let test_encode_roundtrip_basic () =
881
868
let original =
882
-
Table
883
-
[ ("name", String "test"); ("count", Int 42L); ("enabled", Bool true) ]
869
+
table
870
+
[ ("name", string "test"); ("count", int 42L); ("enabled", bool true) ]
884
871
in
885
872
let encoded = to_toml_string original in
886
873
let decoded = parse_toml encoded in
···
888
875
889
876
let test_encode_roundtrip_nested () =
890
877
let original =
891
-
Table
878
+
table
892
879
[
893
-
("server", Table [ ("host", String "localhost"); ("port", Int 8080L) ]);
880
+
("server", table [ ("host", string "localhost"); ("port", int 8080L) ]);
894
881
]
895
882
in
896
883
let encoded = to_toml_string original in
···
898
885
Alcotest.(check value_testable) "roundtrip nested" original decoded
899
886
900
887
let test_encode_roundtrip_array () =
901
-
let original = Table [ ("items", Array [ Int 1L; Int 2L; Int 3L ]) ] in
888
+
let original = table [ ("items", array [ int 1L; int 2L; int 3L ]) ] in
902
889
let encoded = to_toml_string original in
903
890
let decoded = parse_toml encoded in
904
891
Alcotest.(check value_testable) "roundtrip array" original decoded
905
892
906
893
let test_encode_roundtrip_special_string () =
907
-
let original = Table [ ("str", String "line1\nline2\ttab") ] in
894
+
let original = table [ ("str", string "line1\nline2\ttab") ] in
908
895
let encoded = to_toml_string original in
909
896
let decoded = parse_toml encoded in
910
897
Alcotest.(check value_testable) "roundtrip special string" original decoded
911
898
912
899
let test_encode_roundtrip_float () =
913
900
let original =
914
-
Table
901
+
table
915
902
[
916
-
("pi", Float 3.14159);
917
-
("inf", Float Float.infinity);
918
-
("neg_inf", Float Float.neg_infinity);
903
+
("pi", float 3.14159);
904
+
("inf", float Float.infinity);
905
+
("neg_inf", float Float.neg_infinity);
919
906
]
920
907
in
921
908
let encoded = to_toml_string original in
···
924
911
925
912
let test_encode_roundtrip_datetime () =
926
913
let original =
927
-
Table
914
+
table
928
915
[
929
-
("dt", Datetime "1979-05-27T07:32:00Z");
930
-
("ld", Date_local "1979-05-27");
931
-
("lt", Time_local "07:32:00");
916
+
("dt", datetime "1979-05-27T07:32:00Z");
917
+
("ld", date_local "1979-05-27");
918
+
("lt", time_local "07:32:00");
932
919
]
933
920
in
934
921
let encoded = to_toml_string original in
···
963
950
964
951
let test_unicode_key () =
965
952
let t = parse_toml {|"ʎǝʞ" = "value"|} in
966
-
Alcotest.(check value_testable) "unicode key" (String "value") (get "ʎǝʞ" t)
953
+
Alcotest.(check value_testable) "unicode key" (string "value") (get "ʎǝʞ" t)
967
954
968
955
let test_crlf_newlines () =
969
956
let t = parse_toml "key1 = 1\r\nkey2 = 2" in
970
-
Alcotest.(check value_testable) "key1" (Int 1L) (get "key1" t);
971
-
Alcotest.(check value_testable) "key2" (Int 2L) (get "key2" t)
957
+
Alcotest.(check value_testable) "key1" (int 1L) (get "key1" t);
958
+
Alcotest.(check value_testable) "key2" (int 2L) (get "key2" t)
972
959
973
960
let edge_case_tests =
974
961
[
···
1006
993
in
1007
994
let v = datetime_of_ptime ptime in
1008
995
Alcotest.(check value_testable)
1009
-
"datetime_of_ptime UTC" (Datetime "1979-05-27T07:32:00Z") v
996
+
"datetime_of_ptime UTC"
997
+
(datetime "1979-05-27T07:32:00Z")
998
+
v
1010
999
1011
1000
let test_datetime_ptime_tz () =
1012
1001
let ptime =
···
1017
1006
let v = datetime_of_ptime ~tz_offset_s:(-25200) ptime in
1018
1007
(* -07:00 = -25200s *)
1019
1008
Alcotest.(check value_testable)
1020
-
"datetime_of_ptime with tz" (Datetime "1979-05-27T00:32:00-07:00") v
1009
+
"datetime_of_ptime with tz"
1010
+
(datetime "1979-05-27T00:32:00-07:00")
1011
+
v
1021
1012
1022
1013
let test_datetime_ptime_frac () =
1023
1014
let ptime =
···
1027
1018
in
1028
1019
let v = datetime_of_ptime ~frac_s:3 ptime in
1029
1020
Alcotest.(check value_testable)
1030
-
"datetime_of_ptime with frac" (Datetime "1979-05-27T07:32:00.000Z") v
1021
+
"datetime_of_ptime with frac"
1022
+
(datetime "1979-05-27T07:32:00.000Z")
1023
+
v
1031
1024
1032
1025
let test_to_ptime () =
1033
-
let v = Datetime "1979-05-27T07:32:00Z" in
1026
+
let v = datetime "1979-05-27T07:32:00Z" in
1034
1027
let ptime = to_ptime v in
1035
1028
let expected =
1036
1029
match Ptime.of_date_time ((1979, 5, 27), ((7, 32, 0), 0)) with
···
1040
1033
Alcotest.(check ptime_testable) "to_ptime" expected ptime
1041
1034
1042
1035
let test_to_ptime_with_offset () =
1043
-
let v = Datetime "1979-05-27T00:32:00-07:00" in
1036
+
let v = datetime "1979-05-27T00:32:00-07:00" in
1044
1037
let ptime = to_ptime v in
1045
1038
(* UTC time should be 1979-05-27T07:32:00Z *)
1046
1039
let expected =
···
1051
1044
Alcotest.(check ptime_testable) "to_ptime with offset" expected ptime
1052
1045
1053
1046
let test_to_ptime_tz () =
1054
-
let v = Datetime "1979-05-27T00:32:00-07:00" in
1047
+
let v = datetime "1979-05-27T00:32:00-07:00" in
1055
1048
match to_ptime_tz v with
1056
1049
| Some (_, Some tz) -> Alcotest.(check int) "timezone offset" (-25200) tz
1057
1050
| Some (_, None) -> Alcotest.fail "expected timezone offset"
1058
1051
| None -> Alcotest.fail "expected ptime result"
1059
1052
1060
1053
let test_to_ptime_opt_local () =
1061
-
let v = Datetime_local "1979-05-27T07:32:00" in
1054
+
let v = datetime_local "1979-05-27T07:32:00" in
1062
1055
Alcotest.(check (option ptime_testable))
1063
1056
"local datetime returns None" None (to_ptime_opt v)
1064
1057
1065
1058
let test_to_ptime_optional_seconds () =
1066
1059
(* TOML 1.1 allows optional seconds *)
1067
-
let v = Datetime "1979-05-27T07:32Z" in
1060
+
let v = datetime "1979-05-27T07:32Z" in
1068
1061
let ptime = to_ptime v in
1069
1062
let expected =
1070
1063
match Ptime.of_date_time ((1979, 5, 27), ((7, 32, 0), 0)) with
···
1080
1073
| None -> Alcotest.fail "invalid test datetime"
1081
1074
in
1082
1075
let v = date_of_ptime ptime in
1083
-
Alcotest.(check value_testable) "date_of_ptime" (Date_local "1979-05-27") v
1076
+
Alcotest.(check value_testable) "date_of_ptime" (date_local "1979-05-27") v
1084
1077
1085
1078
let test_to_date () =
1086
-
let v = Date_local "1979-05-27" in
1079
+
let v = date_local "1979-05-27" in
1087
1080
let date = to_date v in
1088
1081
Alcotest.(check date_testable) "to_date" (1979, 5, 27) date
1089
1082
1090
1083
let test_to_date_opt_invalid () =
1091
-
let v = Date_local "1979-02-30" in
1084
+
let v = date_local "1979-02-30" in
1092
1085
(* Invalid date *)
1093
1086
Alcotest.(check (option date_testable))
1094
1087
"invalid date returns None" None (to_date_opt v)
···
1120
1113
]
1121
1114
1122
1115
(* ============================================
1123
-
Unified Ptime Datetime
1116
+
Unified Ptime datetime
1124
1117
============================================ *)
1125
1118
1126
1119
let ptime_datetime_testable =
···
1134
1127
| _ -> false)
1135
1128
1136
1129
let test_unified_offset_datetime () =
1137
-
let v = Datetime "1979-05-27T07:32:00Z" in
1130
+
let v = datetime "1979-05-27T07:32:00Z" in
1138
1131
match to_ptime_datetime v with
1139
1132
| Some (`Datetime (ptime, Some 0)) ->
1140
1133
let expected =
···
1151
1144
| None -> Alcotest.fail "expected Some, got None"
1152
1145
1153
1146
let test_unified_offset_tz () =
1154
-
let v = Datetime "1979-05-27T00:32:00-07:00" in
1147
+
let v = datetime "1979-05-27T00:32:00-07:00" in
1155
1148
match to_ptime_datetime v with
1156
1149
| Some (`Datetime (ptime, Some tz)) ->
1157
1150
(* UTC time should be 1979-05-27T07:32:00Z *)
···
1165
1158
| _ -> Alcotest.fail "expected `Datetime with tz"
1166
1159
1167
1160
let test_unified_local_datetime () =
1168
-
let v = Datetime_local "1979-05-27T07:32:00" in
1161
+
let v = datetime_local "1979-05-27T07:32:00" in
1169
1162
(* Use explicit UTC for testing *)
1170
1163
match to_ptime_datetime ~tz_offset_s:0 v with
1171
1164
| Some (`Datetime_local ptime) ->
···
1180
1173
| None -> Alcotest.fail "expected Some, got None"
1181
1174
1182
1175
let test_unified_local_date () =
1183
-
let v = Date_local "1979-05-27" in
1176
+
let v = date_local "1979-05-27" in
1184
1177
match to_ptime_datetime v with
1185
1178
| Some (`Date (year, month, day)) ->
1186
1179
Alcotest.(check int) "year" 1979 year;
···
1191
1184
| None -> Alcotest.fail "expected Some, got None"
1192
1185
1193
1186
let test_unified_local_time () =
1194
-
let v = Time_local "07:32:00" in
1187
+
let v = time_local "07:32:00" in
1195
1188
match to_ptime_datetime v with
1196
1189
| Some (`Time (hour, minute, second, ns)) ->
1197
1190
Alcotest.(check int) "hour" 7 hour;
···
1203
1196
| None -> Alcotest.fail "expected Some, got None"
1204
1197
1205
1198
let test_unified_local_time_frac () =
1206
-
let v = Time_local "07:32:00.123456789" in
1199
+
let v = time_local "07:32:00.123456789" in
1207
1200
match to_ptime_datetime v with
1208
1201
| Some (`Time (hour, minute, second, ns)) ->
1209
1202
Alcotest.(check int) "hour" 7 hour;
···
1258
1251
| None -> Alcotest.fail "roundtrip failed"
1259
1252
1260
1253
let test_unified_not_datetime () =
1261
-
let v = String "not a datetime" in
1254
+
let v = string "not a datetime" in
1262
1255
Alcotest.(check (option ptime_datetime_testable))
1263
1256
"non-datetime" None (to_ptime_datetime v)
1264
1257
+42
-42
ocaml-toml/test_json/test_toml_json.ml
+42
-42
ocaml-toml/test_json/test_toml_json.ml
···
34
34
( "string",
35
35
`Quick,
36
36
test_jsont_decode_encode "string" {|{"type":"string","value":"hello"}|}
37
-
(Toml.String "hello") );
37
+
(Toml.string "hello") );
38
38
( "integer",
39
39
`Quick,
40
40
test_jsont_decode_encode "integer" {|{"type":"integer","value":"42"}|}
41
-
(Toml.Int 42L) );
41
+
(Toml.int 42L) );
42
42
( "float",
43
43
`Quick,
44
44
test_jsont_decode_encode "float" {|{"type":"float","value":"3.14"}|}
45
-
(Toml.Float 3.14) );
45
+
(Toml.float 3.14) );
46
46
( "bool true",
47
47
`Quick,
48
48
test_jsont_decode_encode "bool true" {|{"type":"bool","value":"true"}|}
49
-
(Toml.Bool true) );
49
+
(Toml.bool true) );
50
50
( "bool false",
51
51
`Quick,
52
52
test_jsont_decode_encode "bool false" {|{"type":"bool","value":"false"}|}
53
-
(Toml.Bool false) );
53
+
(Toml.bool false) );
54
54
( "datetime",
55
55
`Quick,
56
56
test_jsont_decode_encode "datetime"
57
57
{|{"type":"datetime","value":"1979-05-27T07:32:00Z"}|}
58
-
(Toml.Datetime "1979-05-27T07:32:00Z") );
58
+
(Toml.datetime "1979-05-27T07:32:00Z") );
59
59
( "datetime-local",
60
60
`Quick,
61
61
test_jsont_decode_encode "datetime-local"
62
62
{|{"type":"datetime-local","value":"1979-05-27T07:32:00"}|}
63
-
(Toml.Datetime_local "1979-05-27T07:32:00") );
63
+
(Toml.datetime_local "1979-05-27T07:32:00") );
64
64
( "date-local",
65
65
`Quick,
66
66
test_jsont_decode_encode "date-local"
67
67
{|{"type":"date-local","value":"1979-05-27"}|}
68
-
(Toml.Date_local "1979-05-27") );
68
+
(Toml.date_local "1979-05-27") );
69
69
( "time-local",
70
70
`Quick,
71
71
test_jsont_decode_encode "time-local"
72
72
{|{"type":"time-local","value":"07:32:00"}|}
73
-
(Toml.Time_local "07:32:00") );
73
+
(Toml.time_local "07:32:00") );
74
74
( "array of integers",
75
75
`Quick,
76
76
test_jsont_decode_encode "array of integers"
77
77
{|[{"type":"integer","value":"1"},{"type":"integer","value":"2"},{"type":"integer","value":"3"}]|}
78
-
(Toml.Array [ Toml.Int 1L; Toml.Int 2L; Toml.Int 3L ]) );
78
+
(Toml.array [ Toml.int 1L; Toml.int 2L; Toml.int 3L ]) );
79
79
( "array of strings",
80
80
`Quick,
81
81
test_jsont_decode_encode "array of strings"
82
82
{|[{"type":"string","value":"a"},{"type":"string","value":"b"}]|}
83
-
(Toml.Array [ Toml.String "a"; Toml.String "b" ]) );
83
+
(Toml.array [ Toml.string "a"; Toml.string "b" ]) );
84
84
( "empty table",
85
85
`Quick,
86
-
test_jsont_decode_encode "empty table" {|{}|} (Toml.Table []) );
86
+
test_jsont_decode_encode "empty table" {|{}|} (Toml.table []) );
87
87
( "simple table",
88
88
`Quick,
89
89
test_jsont_decode_encode "simple table"
90
90
{|{"name":{"type":"string","value":"test"}}|}
91
-
(Toml.Table [ ("name", Toml.String "test") ]) );
91
+
(Toml.table [ ("name", Toml.string "test") ]) );
92
92
( "table with multiple types",
93
93
`Quick,
94
94
test_jsont_decode_encode "table with multiple types"
95
95
{|{"name":{"type":"string","value":"test"},"count":{"type":"integer","value":"5"},"enabled":{"type":"bool","value":"true"}}|}
96
96
(* Note: jsont uses String_map which sorts keys alphabetically *)
97
-
(Toml.Table
97
+
(Toml.table
98
98
[
99
-
("count", Toml.Int 5L);
100
-
("enabled", Toml.Bool true);
101
-
("name", Toml.String "test");
99
+
("count", Toml.int 5L);
100
+
("enabled", Toml.bool true);
101
+
("name", Toml.string "test");
102
102
]) );
103
103
( "nested table",
104
104
`Quick,
105
105
test_jsont_decode_encode "nested table"
106
106
{|{"outer":{"inner":{"type":"string","value":"value"}}}|}
107
-
(Toml.Table [ ("outer", Toml.Table [ ("inner", Toml.String "value") ]) ])
108
-
);
107
+
(Toml.table
108
+
[ ("outer", Toml.table [ ("inner", Toml.string "value") ]) ]) );
109
109
( "table with array",
110
110
`Quick,
111
111
test_jsont_decode_encode "table with array"
112
112
{|{"items":[{"type":"integer","value":"1"},{"type":"integer","value":"2"}]}|}
113
-
(Toml.Table [ ("items", Toml.Array [ Toml.Int 1L; Toml.Int 2L ]) ]) );
113
+
(Toml.table [ ("items", Toml.array [ Toml.int 1L; Toml.int 2L ]) ]) );
114
114
]
115
115
116
116
(* Test cases for native encode/decode (roundtrip with table documents) *)
117
117
let native_tests =
118
118
[
119
-
("empty table", `Quick, test_native_roundtrip "empty table" (Toml.Table []));
119
+
("empty table", `Quick, test_native_roundtrip "empty table" (Toml.table []));
120
120
( "simple table",
121
121
`Quick,
122
122
test_native_roundtrip "simple table"
123
-
(Toml.Table [ ("key", Toml.String "value") ]) );
123
+
(Toml.table [ ("key", Toml.string "value") ]) );
124
124
( "table with all types",
125
125
`Quick,
126
126
test_native_roundtrip "table with all types"
127
-
(Toml.Table
127
+
(Toml.table
128
128
[
129
-
("string", Toml.String "hello");
130
-
("integer", Toml.Int 42L);
131
-
("float", Toml.Float 3.14);
132
-
("bool", Toml.Bool true);
133
-
("datetime", Toml.Datetime "1979-05-27T07:32:00Z");
134
-
("datetime_local", Toml.Datetime_local "1979-05-27T07:32:00");
135
-
("date_local", Toml.Date_local "1979-05-27");
136
-
("time_local", Toml.Time_local "07:32:00");
129
+
("string", Toml.string "hello");
130
+
("integer", Toml.int 42L);
131
+
("float", Toml.float 3.14);
132
+
("bool", Toml.bool true);
133
+
("datetime", Toml.datetime "1979-05-27T07:32:00Z");
134
+
("datetime_local", Toml.datetime_local "1979-05-27T07:32:00");
135
+
("date_local", Toml.date_local "1979-05-27");
136
+
("time_local", Toml.time_local "07:32:00");
137
137
]) );
138
138
( "nested table",
139
139
`Quick,
140
140
test_native_roundtrip "nested table"
141
-
(Toml.Table [ ("outer", Toml.Table [ ("inner", Toml.String "value") ]) ])
142
-
);
141
+
(Toml.table
142
+
[ ("outer", Toml.table [ ("inner", Toml.string "value") ]) ]) );
143
143
( "table with array",
144
144
`Quick,
145
145
test_native_roundtrip "table with array"
146
-
(Toml.Table
147
-
[ ("items", Toml.Array [ Toml.Int 1L; Toml.Int 2L; Toml.Int 3L ]) ])
146
+
(Toml.table
147
+
[ ("items", Toml.array [ Toml.int 1L; Toml.int 2L; Toml.int 3L ]) ])
148
148
);
149
149
( "complex document",
150
150
`Quick,
151
151
test_native_roundtrip "complex document"
152
-
(Toml.Table
152
+
(Toml.table
153
153
[
154
-
("title", Toml.String "TOML Example");
154
+
("title", Toml.string "TOML Example");
155
155
( "database",
156
-
Toml.Table
156
+
Toml.table
157
157
[
158
-
("server", Toml.String "192.168.1.1");
158
+
("server", Toml.string "192.168.1.1");
159
159
( "ports",
160
-
Toml.Array
161
-
[ Toml.Int 8000L; Toml.Int 8001L; Toml.Int 8002L ] );
162
-
("enabled", Toml.Bool true);
160
+
Toml.array
161
+
[ Toml.int 8000L; Toml.int 8001L; Toml.int 8002L ] );
162
+
("enabled", Toml.bool true);
163
163
] );
164
164
]) );
165
165
]
+25
-24
ocaml-toml/test_json/toml_json.ml
+25
-24
ocaml-toml/test_json/toml_json.ml
···
33
33
(* Convert tagged value to TOML *)
34
34
let tagged_to_toml (t : tagged_value) : Toml.t =
35
35
match t.typ with
36
-
| "string" -> Toml.String t.value
37
-
| "integer" -> Toml.Int (Int64.of_string t.value)
36
+
| "string" -> Toml.string t.value
37
+
| "integer" -> Toml.int (Int64.of_string t.value)
38
38
| "float" ->
39
39
let f =
40
40
match t.value with
···
43
43
| "-inf" -> Float.neg_infinity
44
44
| s -> float_of_string s
45
45
in
46
-
Toml.Float f
47
-
| "bool" -> Toml.Bool (t.value = "true")
48
-
| "datetime" -> Toml.Datetime t.value
49
-
| "datetime-local" -> Toml.Datetime_local t.value
50
-
| "date-local" -> Toml.Date_local t.value
51
-
| "time-local" -> Toml.Time_local t.value
46
+
Toml.float f
47
+
| "bool" -> Toml.bool (t.value = "true")
48
+
| "datetime" -> Toml.datetime t.value
49
+
| "datetime-local" -> Toml.datetime_local t.value
50
+
| "date-local" -> Toml.date_local t.value
51
+
| "time-local" -> Toml.time_local t.value
52
52
| typ -> failwith ("Unknown tagged type: " ^ typ)
53
53
54
54
(* Convert TOML scalar to tagged value *)
55
55
let toml_to_tagged (v : Toml.t) : tagged_value =
56
56
match v with
57
-
| Toml.String s -> { typ = "string"; value = s }
58
-
| Toml.Int i -> { typ = "integer"; value = Int64.to_string i }
59
-
| Toml.Float f ->
57
+
| Toml.String (s, _) -> { typ = "string"; value = s }
58
+
| Toml.Int (i, _) -> { typ = "integer"; value = Int64.to_string i }
59
+
| Toml.Float (f, _) ->
60
60
let value =
61
61
if Float.is_nan f then "nan"
62
62
else if f = Float.infinity then "inf"
···
65
65
else Fmt.str "%g" f
66
66
in
67
67
{ typ = "float"; value }
68
-
| Toml.Bool b -> { typ = "bool"; value = (if b then "true" else "false") }
69
-
| Toml.Datetime s -> { typ = "datetime"; value = s }
70
-
| Toml.Datetime_local s -> { typ = "datetime-local"; value = s }
71
-
| Toml.Date_local s -> { typ = "date-local"; value = s }
72
-
| Toml.Time_local s -> { typ = "time-local"; value = s }
68
+
| Toml.Bool (b, _) ->
69
+
{ typ = "bool"; value = (if b then "true" else "false") }
70
+
| Toml.Datetime (s, _) -> { typ = "datetime"; value = s }
71
+
| Toml.Datetime_local (s, _) -> { typ = "datetime-local"; value = s }
72
+
| Toml.Date_local (s, _) -> { typ = "date-local"; value = s }
73
+
| Toml.Time_local (s, _) -> { typ = "time-local"; value = s }
73
74
| Toml.Array _ | Toml.Table _ ->
74
75
failwith "Cannot convert non-scalar TOML value to tagged value"
75
76
···
104
105
and toml_array : Toml.t Json.codec Lazy.t =
105
106
lazy
106
107
(Json.Codec.map
107
-
~dec:(fun items -> Toml.Array items)
108
+
~dec:(fun items -> Toml.array items)
108
109
~enc:(function
109
-
| Toml.Array items -> items | _ -> failwith "Expected array")
110
+
| Toml.Array (items, _) -> items | _ -> failwith "Expected array")
110
111
(Json.Codec.list (Json.Codec.rec' toml_json)))
111
112
112
113
and toml_object : Toml.t Json.codec Lazy.t =
···
124
125
let pairs =
125
126
match typ_opt with
126
127
| Some typ ->
127
-
let typ_toml = Toml.String typ in
128
+
let typ_toml = Toml.string typ in
128
129
("type", typ_toml) :: pairs
129
130
| None -> pairs
130
131
in
131
132
let pairs =
132
133
match value_opt with
133
134
| Some value ->
134
-
let value_toml = Toml.String value in
135
+
let value_toml = Toml.string value in
135
136
("value", value_toml) :: pairs
136
137
| None -> pairs
137
138
in
138
-
Toml.Table pairs)
139
+
Toml.table pairs)
139
140
|> opt_mem "type" Json.Codec.string ~enc:(fun _ -> None)
140
141
|> opt_mem "value" Json.Codec.string ~enc:(fun _ -> None)
141
142
|> keep_unknown
···
153
154
and toml_table_enc : Toml.t Json.codec Lazy.t =
154
155
lazy
155
156
Json.Codec.Object.(
156
-
map (fun m -> Toml.Table (String_map.bindings m))
157
+
map (fun m -> Toml.table (String_map.bindings m))
157
158
|> keep_unknown
158
159
(Mems.string_map (Json.Codec.rec' toml_json))
159
160
~enc:(function
160
-
| Toml.Table pairs ->
161
+
| Toml.Table (pairs, _) ->
161
162
List.fold_left
162
-
(fun m (k, v) -> String_map.add k v m)
163
+
(fun m ((k, _), v) -> String_map.add k v m)
163
164
String_map.empty pairs
164
165
| _ -> failwith "Expected table")
165
166
|> finish)
-1
ocaml-turbo/fuzz/dune
-1
ocaml-turbo/fuzz/dune
-1
ocaml-udpcl/c/dune
-1
ocaml-udpcl/c/dune
-1
ocaml-udpcl/fuzz/dune
-1
ocaml-udpcl/fuzz/dune
-1
ocaml-uslp/c/dune
-1
ocaml-uslp/c/dune
-1
ocaml-uslp/fuzz/dune
-1
ocaml-uslp/fuzz/dune
-1
ocaml-viterbi/fuzz/dune
-1
ocaml-viterbi/fuzz/dune
-1
ocaml-vz/fuzz/dune
-1
ocaml-vz/fuzz/dune
-1
ocaml-vz/test/dune
-1
ocaml-vz/test/dune
-1
ocaml-wal/fuzz/dune
-1
ocaml-wal/fuzz/dune
-1
ocaml-websocket/fuzz/dune
-1
ocaml-websocket/fuzz/dune
-3
ocaml-x509/tests/custom_pp/custom_pp.ml
-3
ocaml-x509/tests/custom_pp/custom_pp.ml
···
3
3
4
4
let fido_u2f_transport_oid_name = "id-fido-u2f-ce-transports"
5
5
6
-
type transport =
7
-
[ `Bluetooth_classic | `Bluetooth_low_energy | `Usb | `Nfc | `Usb_internal ]
8
-
9
6
let pp_transport ppf = function
10
7
| `Bluetooth_classic -> Fmt.string ppf "BluetoothClassic"
11
8
| `Bluetooth_low_energy -> Fmt.string ppf "BluetoothLowEnergy"
-1
ocaml-x509/tests/custom_pp/dune
-1
ocaml-x509/tests/custom_pp/dune
-1
ocaml-xff/fuzz/dune
-1
ocaml-xff/fuzz/dune
-1
ocaml-xff/test/dune
-1
ocaml-xff/test/dune
+3
-1
ocaml-xml/bench/bench_xml.ml
+3
-1
ocaml-xml/bench/bench_xml.ml
···
118
118
Buffer.add_string buf "</items>";
119
119
Buffer.contents buf
120
120
in
121
-
let items_codec = Xml.Codec.(element "items" (list (element "item" string))) in
121
+
let items_codec =
122
+
Xml.Codec.(element "items" (list (element "item" string)))
123
+
in
122
124
bench_codec "codec: 100 items list" items_xml items_codec 1000;
123
125
124
126
(* Selective codec: decode only 2 attrs from element with many children *)
+4
-4
ocaml-xml/lib/codec.mli
+4
-4
ocaml-xml/lib/codec.mli
···
148
148
149
149
val skip : unit t
150
150
(** [skip] decodes any element to [()] while discarding its body (does not
151
-
materialize a [Value.t]). Use it to filter unneeded element classes
152
-
when iterating a large document: e.g. [list skip] consumes a list of
153
-
elements you don't care about, or [El.child_opt "trace" skip] drops a
154
-
known-uninteresting child. Encoder emits an empty element. *)
151
+
materialize a [Value.t]). Use it to filter unneeded element classes when
152
+
iterating a large document: e.g. [list skip] consumes a list of elements you
153
+
don't care about, or [El.child_opt "trace" skip] drops a known-uninteresting
154
+
child. Encoder emits an empty element. *)
155
155
156
156
val decode_stream : 'a t -> Core.P.stream -> 'a
157
157
(** [decode_stream c s] consumes preamble, one root element, and trailing misc
+1
-2
ocaml-xml/lib/core.ml
+1
-2
ocaml-xml/lib/core.ml
···
488
488
loop ()
489
489
| c when is_forbidden_ascii_byte c ->
490
490
err_msg_at (loc s)
491
-
(Fmt.str "character #x%02X forbidden in XML content"
492
-
(Char.code c))
491
+
(Fmt.str "character #x%02X forbidden in XML content" (Char.code c))
493
492
| c ->
494
493
Buffer.add_char buf c;
495
494
advance s;
+3
-23
ocaml-xml/lib/xml.ml
+3
-23
ocaml-xml/lib/xml.ml
···
27
27
type t = Value.t
28
28
type 'a codec = 'a Codec.t
29
29
30
-
(* Re-exports from Codec for ergonomic top-level access. *)
31
-
32
-
module Attr = Codec.Attr
33
-
module El = Codec.El
34
-
35
-
let pp = Codec.pp
36
-
let string = Codec.string
37
-
let int = Codec.int
38
-
let float = Codec.float
39
-
let bool = Codec.bool
40
-
let element = Codec.element
41
-
let map = Codec.map
42
-
let const = Codec.const
43
-
let option = Codec.option
44
-
let list = Codec.list
45
-
let rec' = Codec.rec'
46
-
let child = Codec.child
47
-
let attr = Codec.attr
48
-
let nth = Codec.nth
49
-
let kind = Codec.kind
50
-
51
-
(* Top-level I/O entry points. *)
30
+
(* Top-level I/O entry points. Combinators live in [Codec]
31
+
([Xml.Codec.string], [Xml.Codec.El.obj], [Xml.Codec.list], ...) per
32
+
the ocaml-encodings skill; keep the top level focused on IO. *)
52
33
53
34
let of_reader_exn ?(max_depth = 100) ?(max_nodes = 10_000_000) codec reader =
54
35
let stream = Core.P.make_stream ~max_depth ~max_nodes reader in
···
78
59
Codec.enc_value codec e v
79
60
80
61
(* Cursor: zipper over Value.t with XPath-subset pointers. *)
81
-
82
62
83
63
(* Cursor: zipper over Value.t with XPath-subset pointers. Lives in
84
64
[cursor.ml] now; re-exported here for [Xml.Cursor.*] access. *)
+1
-6
ocaml-xml/test/test.ml
+1
-6
ocaml-xml/test/test.ml
+6
-2
ocaml-xml/test/test_codec.ml
+6
-2
ocaml-xml/test/test_codec.ml
···
27
27
(decode_ok (Xml.Codec.element "t" Xml.Codec.bool) "<t>true</t>")
28
28
29
29
let test_list () =
30
-
let codec = Xml.Codec.element "xs" (Xml.Codec.list (Xml.Codec.element "x" Xml.Codec.int)) in
30
+
let codec =
31
+
Xml.Codec.element "xs"
32
+
(Xml.Codec.list (Xml.Codec.element "x" Xml.Codec.int))
33
+
in
31
34
let v = decode_ok codec "<xs><x>1</x><x>2</x><x>3</x></xs>" in
32
35
Alcotest.(check (list int)) "list" [ 1; 2; 3 ] v
33
36
···
39
42
40
43
let test_map () =
41
44
let codec =
42
-
Xml.Codec.(element "n" (map ~dec:(fun x -> x * 2) ~enc:(fun x -> x / 2) int))
45
+
Xml.Codec.(
46
+
element "n" (map ~dec:(fun x -> x * 2) ~enc:(fun x -> x / 2) int))
43
47
in
44
48
let v = decode_ok codec "<n>21</n>" in
45
49
Alcotest.(check int) "map dec" 42 v;
+6
-10
ocaml-xml/test/test_cursor.ml
+6
-10
ocaml-xml/test/test_cursor.ml
···
36
36
let test_attr_ops () =
37
37
let c = Xml.Cursor.root (sample ()) in
38
38
let c' = Xml.Cursor.set_attr "c" "3" c in
39
-
Alcotest.(check (option string))
40
-
"added c" (Some "3") (Xml.Cursor.attr "c" c');
41
-
Alcotest.(check (option string))
42
-
"kept a" (Some "1") (Xml.Cursor.attr "a" c');
39
+
Alcotest.(check (option string)) "added c" (Some "3") (Xml.Cursor.attr "c" c');
40
+
Alcotest.(check (option string)) "kept a" (Some "1") (Xml.Cursor.attr "a" c');
43
41
let c'' = Xml.Cursor.del_attr "b" c' in
44
-
Alcotest.(check (option string))
45
-
"removed b" None (Xml.Cursor.attr "b" c'')
42
+
Alcotest.(check (option string)) "removed b" None (Xml.Cursor.attr "b" c'')
46
43
47
44
let test_pointer_roundtrip () =
48
45
let v = sample () in
···
68
65
| None -> Alcotest.fail "of_context roundtrip"
69
66
| Some c2 ->
70
67
Alcotest.(check string)
71
-
"same focus"
72
-
(Xml.Cursor.focus c1).tag
73
-
(Xml.Cursor.focus c2).tag
68
+
"same focus" (Xml.Cursor.focus c1).tag (Xml.Cursor.focus c2).tag
74
69
75
70
let test_top_rebuild () =
76
71
let c = Xml.Cursor.root (sample ()) in
···
87
82
match root.children with
88
83
| Xml.Value.Element first :: _ ->
89
84
Alcotest.(check (option string))
90
-
"new attr" (Some "yes") (List.assoc_opt "new" first.attrs)
85
+
"new attr" (Some "yes")
86
+
(List.assoc_opt "new" first.attrs)
91
87
| _ -> Alcotest.fail "no first child element"
92
88
93
89
let suite =
+3
-3
ocaml-xml/test/test_value.ml
+3
-3
ocaml-xml/test/test_value.ml
···
16
16
let test_parse_simple () =
17
17
let el = parse_ok "<a x=\"1\">hello</a>" in
18
18
Alcotest.(check string) "tag" "a" el.tag;
19
-
Alcotest.(check (option string))
20
-
"attr x" (Some "1") (Xml.Value.attr "x" el);
19
+
Alcotest.(check (option string)) "attr x" (Some "1") (Xml.Value.attr "x" el);
21
20
Alcotest.(check string) "text" "hello" (Xml.Value.text el)
22
21
23
22
let test_parse_then_serialize () =
···
46
45
(match Xml.Value.path [ "a"; "b"; "c" ] el with
47
46
| Some e -> Xml.Value.text e = "deep"
48
47
| None -> false);
49
-
Alcotest.(check bool) "path missing" true
48
+
Alcotest.(check bool)
49
+
"path missing" true
50
50
(Xml.Value.path [ "a"; "x" ] el = None)
51
51
52
52
let test_pp () =
+29
-8
ocaml-xml/test/test_xml.ml
+29
-8
ocaml-xml/test/test_xml.ml
···
1167
1167
Alcotest.(check int) "get_child age" 30 v
1168
1168
1169
1169
let test_get_child_nested () =
1170
-
let codec = Xml.Codec.child "config" (Xml.Codec.child "host" Xml.Codec.string) in
1170
+
let codec =
1171
+
Xml.Codec.child "config" (Xml.Codec.child "host" Xml.Codec.string)
1172
+
in
1171
1173
let v =
1172
1174
decode_ok codec
1173
1175
"<root><config><host>localhost</host><port>8080</port></config></root>"
···
1217
1219
1218
1220
(* kind: introspection *)
1219
1221
let test_kind_string () =
1220
-
Alcotest.(check string) "kind string" "string" (Xml.Codec.kind Xml.Codec.string)
1222
+
Alcotest.(check string)
1223
+
"kind string" "string"
1224
+
(Xml.Codec.kind Xml.Codec.string)
1221
1225
1222
1226
let test_kind_int () =
1223
1227
Alcotest.(check string) "kind int" "int" (Xml.Codec.kind Xml.Codec.int)
···
1466
1470
"msg" "missing required attribute \"host\" on element" (msg_of e)
1467
1471
1468
1472
let test_error_context_list_index () =
1469
-
let codec = Xml.Codec.element "items" (Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int)) in
1473
+
let codec =
1474
+
Xml.Codec.element "items"
1475
+
(Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int))
1476
+
in
1470
1477
let e = decode_err' codec "<items><n>1</n><n>bad</n><n>3</n></items>" in
1471
1478
Alcotest.(check frames_t) "frames" [ ("list of <n>", "#1") ] (frames e);
1472
1479
Alcotest.(check string) "msg" "expected integer, got \"bad\"" (msg_of e)
···
1474
1481
let test_error_ctx_list_first () =
1475
1482
(* Edge case: error on the first item must have index 0, not index
1476
1483
1 (off-by-one guard). *)
1477
-
let codec = Xml.Codec.element "items" (Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int)) in
1484
+
let codec =
1485
+
Xml.Codec.element "items"
1486
+
(Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int))
1487
+
in
1478
1488
let e = decode_err' codec "<items><n>bad</n></items>" in
1479
1489
Alcotest.(check frames_t) "frames" [ ("list of <n>", "#0") ] (frames e)
1480
1490
···
1570
1580
Alcotest.(check string) "msg" "expected integer, got \"bad\"" (msg_of e)
1571
1581
1572
1582
let test_ctx_via_err_list () =
1573
-
let codec = Xml.Codec.element "items" (Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int)) in
1583
+
let codec =
1584
+
Xml.Codec.element "items"
1585
+
(Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int))
1586
+
in
1574
1587
let xml = "<items><n>1</n><n>2</n><n>bad</n></items>" in
1575
1588
let e =
1576
1589
match Xml.of_string codec xml with
···
1670
1683
^ String.concat "" (List.init 1000 (fun _ -> "<n>1</n>"))
1671
1684
^ "</root>"
1672
1685
in
1673
-
let codec = Xml.Codec.element "root" (Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int)) in
1686
+
let codec =
1687
+
Xml.Codec.element "root"
1688
+
(Xml.Codec.list (Xml.Codec.element "n" Xml.Codec.int))
1689
+
in
1674
1690
match Xml.of_string ~max_nodes:100 codec xml with
1675
1691
| Ok _ -> Alcotest.fail "max_nodes=100 should reject 1000-child doc"
1676
1692
| Error _ -> ()
···
2245
2261
2246
2262
let test_stream_roundtrip () =
2247
2263
let xml = "<root><a>1</a><a>2</a><a>3</a></root>" in
2248
-
let codec = Xml.Codec.element "root" (Xml.Codec.list (Xml.Codec.element "a" Xml.Codec.int)) in
2264
+
let codec =
2265
+
Xml.Codec.element "root"
2266
+
(Xml.Codec.list (Xml.Codec.element "a" Xml.Codec.int))
2267
+
in
2249
2268
let r = Bytesrw.Bytes.Reader.of_string xml in
2250
2269
let v =
2251
2270
match Xml.of_reader codec r with
···
2293
2312
Buffer.add_string buf (Fmt.str "<a>%d</a>" i)
2294
2313
done;
2295
2314
Buffer.add_string buf "</r>";
2296
-
let codec = Xml.Codec.element "r" (Xml.Codec.list (Xml.Codec.element "a" Xml.Codec.int)) in
2315
+
let codec =
2316
+
Xml.Codec.element "r" (Xml.Codec.list (Xml.Codec.element "a" Xml.Codec.int))
2317
+
in
2297
2318
let r = Bytesrw.Bytes.Reader.of_string (Buffer.contents buf) in
2298
2319
match Xml.of_reader codec r with
2299
2320
| Ok v ->
-1
osrelease/test/dune
-1
osrelease/test/dune
+1
-1
root.opam
+1
-1
root.opam