Declarative JSON data manipulation for OCaml
ocaml-json: unify Error with ocaml-loc
Rebase Json.Error entirely on Loc.Error:
- [type kind] is now Loc.Error.kind (extensible) instead of a tagged
string. Kind extensions registered here use the Loc.Error printer
registry and are pattern-matchable from anywhere that knows about
them.
- [type t] is Loc.Error.t.
- Module Context is Loc.Error.Context.
- exception Error is rebound to Loc.Error so catching either works
transparently across all codecs sharing the loc vocabulary.
- Constructors/raisers follow the loc API: [v] / [msg] construct,
[raise] / [fail] / [failf] raise. The old [make_msg] / [msg (as raiser)]
/ [msgf] names are gone from the public API; callers updated.
Two JSON-specific typed kinds registered at load time:
- [Sort_mismatch of { exp; fnd }] for sort errors (exp: Sort.t, fnd:
Sort.t)
- [Kinded_sort_mismatch of { exp; fnd }] for kinded-sort errors (exp:
string label, fnd: Sort.t)
Helpers [Error.sort] and [Error.kinded_sort] now raise the typed kinds
directly; consumers matching on specific error shapes can pattern-match
instead of doing substring matching on the formatted message.
+55
-93
+2
-2
lib/brr/json_brr.ml
+2
-2
lib/brr/json_brr.ml
···
11
11
12
12
let jv_error_to_error e =
13
13
let ctx = Json.Error.Context.empty and meta = Json.Meta.none in
14
-
Json.Error.make_msg ctx meta (Jstr.to_string (Jv.Error.message e))
14
+
Json.Error.msg ctx meta (Jstr.to_string (Jv.Error.message e))
15
15
16
16
(* Browser JSON codec *)
17
17
···
45
45
else if Jstr.equal t type_object then
46
46
if Jv.is_array jv then Json.Sort.Array else Json.Sort.Object
47
47
else
48
-
Json.Error.msgf Json.Meta.none "Not a JSON value: %s" (Jstr.to_string t)
48
+
Json.Error.failf Json.Meta.none "Not a JSON value: %s" (Jstr.to_string t)
49
49
50
50
(* Getting the members of a Jv.t object in various ways *)
51
51
+3
-3
lib/bytesrw/json_bytesrw.ml
+3
-3
lib/bytesrw/json_bytesrw.ml
···
126
126
Json.Meta.make
127
127
@@ textloc_of_pos d ~first_byte ~last_byte ~first_line ~last_line
128
128
129
-
let err_here d fmt = Json.Error.msgf (error_meta d) fmt
129
+
let err_here d fmt = Json.Error.failf (error_meta d) fmt
130
130
131
131
let err_to_here ~first_byte ~first_line d fmt =
132
-
Json.Error.msgf (error_meta_to_current ~first_byte ~first_line d) fmt
132
+
Json.Error.failf (error_meta_to_current ~first_byte ~first_line d) fmt
133
133
134
134
let err_malformed_utf_8 d =
135
135
if d.i_next > d.i_max then
···
166
166
(* Errors for numbers *)
167
167
168
168
let err_float_parse meta tok =
169
-
Json.Error.msgf meta "Could not parse %S to a %a" tok pp_code "float"
169
+
Json.Error.failf meta "Could not parse %S to a %a" tok pp_code "float"
170
170
171
171
let err_exp_digit d =
172
172
err_exp_while d pp_code "decimal digit" pp_code "number" pp_quchar d.u
+38
-76
lib/json.ml
+38
-76
lib/json.ml
···
20
20
module Path = Loc.Path
21
21
module Sort = Json_base.Sort
22
22
23
-
type error_kind = string
24
-
type context_index = string node * Path.index
25
-
type context = context_index list
26
-
type error = context * Meta.t * error_kind
23
+
exception Error = Loc.Error
27
24
28
-
exception Error of error
25
+
(* Json-specific typed error kinds. Registered with Loc.Error's printer
26
+
registry so [Loc.Error.kind_to_string] formats them correctly. *)
29
27
30
-
module Error = struct
31
-
(* Kinds of errors *)
28
+
type Loc.Error.kind +=
29
+
| Sort_mismatch of { exp : Sort.t; fnd : Sort.t }
30
+
| Kinded_sort_mismatch of { exp : string; fnd : Sort.t }
32
31
33
-
type kind = error_kind
34
-
35
-
let kind_to_string k = k
36
-
37
-
(* Errors *)
38
-
39
-
module Context = struct
40
-
type index = context_index
41
-
type t = context
42
-
43
-
let empty = []
44
-
let is_empty ctx = ctx = []
45
-
let push_array kinded_sort n ctx = (kinded_sort, Path.Nth n) :: ctx
46
-
let push_object kinded_sort n ctx = (kinded_sort, Path.Mem n) :: ctx
47
-
48
-
let pp ppf ctx =
49
-
let pp_meta ppf meta =
50
-
if Meta.is_none meta then ()
51
-
else Fmt.pf ppf "%a: " Textloc.pp (Meta.textloc meta)
52
-
in
53
-
let pp_el ppf (kind, index) =
54
-
match index with
55
-
| Path.Nth (n, meta) ->
56
-
Fmt.pf ppf "@[<v>%aat index %a of@,%a%a@]" pp_meta meta pp_int n
57
-
pp_meta (snd kind) pp_kind (fst kind)
58
-
| Path.Mem (name, meta) ->
59
-
Fmt.pf ppf "@[<v>%ain member %a of@,%a%a@]" pp_meta meta pp_name
60
-
name pp_meta (snd kind) pp_kind (fst kind)
61
-
in
62
-
if ctx = [] then ()
63
-
else Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_el) (List.rev ctx)
64
-
end
65
-
66
-
type t = error
67
-
68
-
let make_msg ctx meta msg = (ctx, meta, msg)
69
-
let raise ctx meta msg = raise_notrace (Error (ctx, meta, msg))
70
-
let msg meta msg = raise_notrace (Error (Context.empty, meta, msg))
71
-
let msgf meta fmt = Format.kasprintf (fun m -> msg meta m) fmt
32
+
let () =
33
+
Loc.Error.register_kind_printer (function
34
+
| Sort_mismatch { exp; fnd } ->
35
+
Some
36
+
(fun ppf ->
37
+
Fmt.pf ppf "Expected %a but found %a" Sort.pp exp Sort.pp fnd)
38
+
| Kinded_sort_mismatch { exp; fnd } ->
39
+
Some
40
+
(fun ppf ->
41
+
Fmt.pf ppf "Expected %a but found %a" Fmt.code exp Sort.pp fnd)
42
+
| _ -> None)
72
43
73
-
let push_array kinded_sort n (ctx, meta, e) =
74
-
raise_notrace (Error (Context.push_array kinded_sort n ctx, meta, e))
44
+
module Error = struct
45
+
type kind = Loc.Error.kind = ..
46
+
type t = Loc.Error.t
75
47
76
-
let push_object kinded_sort n (ctx, meta, e) =
77
-
raise_notrace (Error (Context.push_object kinded_sort n ctx, meta, e))
48
+
module Context = Loc.Error.Context
78
49
79
-
let adjust_context ~first_byte ~first_line_num ~first_line_byte (ctx, meta, e)
80
-
=
81
-
match ctx with
82
-
| [] -> raise_notrace (Error (ctx, meta, e))
83
-
| ((sort, smeta), idx) :: is ->
84
-
let textloc = Meta.textloc smeta in
85
-
let textloc =
86
-
if Textloc.is_none textloc then textloc
87
-
else
88
-
Textloc.set_first textloc ~first_byte ~first_line_num
89
-
~first_line_byte
90
-
in
91
-
let smeta = Meta.with_textloc smeta textloc in
92
-
let ctx = ((sort, smeta), idx) :: is in
93
-
raise_notrace (Error (ctx, meta, e))
50
+
let kind_to_string = Loc.Error.kind_to_string
51
+
let v = Loc.Error.v
52
+
let msg = Loc.Error.msg
53
+
let raise = Loc.Error.raise
54
+
let fail = Loc.Error.fail
55
+
let failf = Loc.Error.failf
56
+
let msgf = Loc.Error.failf (* legacy alias used internally *)
94
57
95
-
let pp ppf (ctx, m, msg) =
96
-
let pp_meta ppf m =
97
-
if not (Meta.is_none m) then
98
-
Fmt.pf ppf "@,%a:" Textloc.pp (Meta.textloc m)
99
-
in
100
-
Fmt.pf ppf "@[<v>%a%a%a@]" Fmt.lines msg pp_meta m Context.pp ctx
58
+
let make_msg ctx meta s = Loc.Error.v ctx meta (Loc.Error.Msg s)
59
+
(* legacy alias: construct from string *)
101
60
102
-
let to_string e = Format.asprintf "%a" pp e
103
-
let puterr = Fmt.puterr
61
+
let push_array = Loc.Error.push_array
62
+
let push_object = Loc.Error.push_object
63
+
let adjust_context = Loc.Error.adjust_context
64
+
let pp = Loc.Error.pp
65
+
let to_string = Loc.Error.to_string
66
+
let puterr = Loc.Error.puterr
104
67
let disable_ansi_styler = Fmt.disable_ansi_styler
105
68
106
69
(* Predefined errors *)
···
108
71
let expected meta exp ~fnd =
109
72
msgf meta "Expected %a but found %a" Fmt.code exp Fmt.code fnd
110
73
111
-
let sort meta ~exp ~fnd =
112
-
msgf meta "Expected %a but found %a" Sort.pp exp Sort.pp fnd
74
+
let sort meta ~exp ~fnd = raise Context.empty meta (Sort_mismatch { exp; fnd })
113
75
114
76
let kinded_sort meta ~exp ~fnd =
115
-
msgf meta "Expected %a but found %a" Fmt.code exp Sort.pp fnd
77
+
raise Context.empty meta (Kinded_sort_mismatch { exp; fnd })
116
78
117
79
let missing_mems meta ~kinded_sort ~exp ~fnd =
118
80
let pp_miss ppf m =
+12
-12
lib/json.mli
+12
-12
lib/json.mli
···
110
110
(** The type for errors. The context, the error localisation and the kind of
111
111
error. *)
112
112
113
+
val v : Context.t -> Meta.t -> kind -> t
114
+
(** [v ctx meta k] constructs an error with a typed kind. *)
115
+
116
+
val msg : Context.t -> Meta.t -> string -> t
117
+
(** [msg ctx meta s] constructs an error from a plain string. *)
118
+
113
119
val raise : Context.t -> Meta.t -> kind -> 'a
114
-
(** [raise ctx meta k] raises an error with given paramters. *)
120
+
(** [raise ctx meta k] raises an error with a typed kind. *)
115
121
116
-
val make_msg : Context.t -> Meta.t -> string -> t
117
-
(** [make_msg ctx meta msg] is an error with message [msg] for meta [meta] in
118
-
context [ctx]. *)
122
+
val fail : Meta.t -> string -> 'a
123
+
(** [fail meta s] raises an error with empty context and message [s]. *)
119
124
120
-
val msg : Meta.t -> string -> 'a
121
-
(** [msg meta msg] raises an error with message [msg] for meta [meta] in an
122
-
empty context. *)
123
-
124
-
val msgf : Meta.t -> ('a, Stdlib.Format.formatter, unit, 'b) format4 -> 'a
125
-
(** [msgf meta fmt …] is like {!val-msg} but formats an error message. *)
125
+
val failf : Meta.t -> ('a, Stdlib.Format.formatter, unit, 'b) format4 -> 'a
126
+
(** [failf meta fmt] is like {!fail} but formats the message. *)
126
127
127
128
val expected : Meta.t -> string -> fnd:string -> 'a
128
129
(** [expected meta fmt exp ~fnd] is [msgf "Expected %s but found %s" exp fnd].
···
164
165
end
165
166
166
167
exception Error of Error.t
167
-
(** The exception raised on map errors. In general codec and query functions
168
-
turn that for you into a {!result} value. *)
168
+
(** The exception raised on map errors. *)
169
169
170
170
(** {1:types Types} *)
171
171