Decouple hint handling in sexp parser from Import
This commit is contained in:
parent
6dee7c9c39
commit
5147de3873
|
@ -33,6 +33,19 @@ let report_with_backtrace exn =
|
||||||
in
|
in
|
||||||
let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s\n" msg in
|
let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s\n" msg in
|
||||||
{ p with loc = Some loc; pp }
|
{ p with loc = Some loc; pp }
|
||||||
|
| Sexp.Of_sexp.Of_sexp (loc, msg, hint') ->
|
||||||
|
let loc =
|
||||||
|
{ loc with
|
||||||
|
start = { loc.start with pos_fname = !map_fname loc.start.pos_fname }
|
||||||
|
}
|
||||||
|
in
|
||||||
|
let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s%s\n" msg
|
||||||
|
(match hint' with
|
||||||
|
| None -> ""
|
||||||
|
| Some { Sexp.Of_sexp. on; candidates } ->
|
||||||
|
hint on candidates)
|
||||||
|
in
|
||||||
|
{ p with loc = Some loc; pp }
|
||||||
| Usexp.Parser.Error e ->
|
| Usexp.Parser.Error e ->
|
||||||
let pos = Usexp.Parser.Error.position e in
|
let pos = Usexp.Parser.Error.position e in
|
||||||
let msg = Usexp.Parser.Error.message e in
|
let msg = Usexp.Parser.Error.message e in
|
||||||
|
|
34
src/sexp.ml
34
src/sexp.ml
|
@ -122,13 +122,20 @@ module Of_sexp = struct
|
||||||
| Quoted_string of Loc.t * string
|
| Quoted_string of Loc.t * string
|
||||||
| List of Loc.t * ast list
|
| List of Loc.t * ast list
|
||||||
|
|
||||||
|
type hint =
|
||||||
|
{ on: string
|
||||||
|
; candidates: string list
|
||||||
|
}
|
||||||
|
|
||||||
|
exception Of_sexp of Loc.t * string * hint option
|
||||||
|
|
||||||
type 'a t = ast -> 'a
|
type 'a t = ast -> 'a
|
||||||
|
|
||||||
let located f sexp =
|
let located f sexp =
|
||||||
(Ast.loc sexp, f sexp)
|
(Ast.loc sexp, f sexp)
|
||||||
|
|
||||||
let of_sexp_error sexp str = raise (Loc.Error (Ast.loc sexp, str))
|
let of_sexp_error ?hint sexp str = raise (Of_sexp (Ast.loc sexp, str, hint))
|
||||||
let of_sexp_errorf sexp fmt = ksprintf (of_sexp_error sexp) fmt
|
let of_sexp_errorf ?hint sexp fmt = ksprintf (of_sexp_error ?hint sexp) fmt
|
||||||
|
|
||||||
let raw x = x
|
let raw x = x
|
||||||
|
|
||||||
|
@ -338,8 +345,8 @@ module Of_sexp = struct
|
||||||
| List (_, s :: _) -> s
|
| List (_, s :: _) -> s
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
in
|
in
|
||||||
of_sexp_errorf name_sexp
|
of_sexp_errorf ~hint:({ on = name ; candidates = state.known})
|
||||||
"Unknown field %s%s" name (hint name state.known)
|
name_sexp "Unknown field %s" name
|
||||||
|
|
||||||
type ('a, 'b) rest =
|
type ('a, 'b) rest =
|
||||||
| No_rest : ('a, 'a) rest
|
| No_rest : ('a, 'a) rest
|
||||||
|
@ -413,11 +420,11 @@ module Of_sexp = struct
|
||||||
| Some cstr -> cstr
|
| Some cstr -> cstr
|
||||||
| None ->
|
| None ->
|
||||||
of_sexp_errorf sexp
|
of_sexp_errorf sexp
|
||||||
"Unknown constructor %s%s" name
|
~hint:{ on = String.uncapitalize name
|
||||||
(hint
|
; candidates = List.map cstrs ~f:(fun c ->
|
||||||
(String.uncapitalize name)
|
String.uncapitalize (C.name c))
|
||||||
(List.map cstrs ~f:(fun c ->
|
}
|
||||||
String.uncapitalize (C.name c))))
|
"Unknown constructor %s" name
|
||||||
|
|
||||||
let sum cstrs sexp =
|
let sum cstrs sexp =
|
||||||
match sexp with
|
match sexp with
|
||||||
|
@ -447,9 +454,8 @@ module Of_sexp = struct
|
||||||
| Some (_, value) -> value
|
| Some (_, value) -> value
|
||||||
| None ->
|
| None ->
|
||||||
of_sexp_errorf sexp
|
of_sexp_errorf sexp
|
||||||
"Unknown value %s%s" s
|
~hint:{ on = String.uncapitalize s
|
||||||
(hint
|
; candidates =List.map cstrs ~f:(fun (name, _) ->
|
||||||
(String.uncapitalize s)
|
String.uncapitalize name) }
|
||||||
(List.map cstrs ~f:(fun (name, _) ->
|
"Unknown value %s" s
|
||||||
String.uncapitalize name)))
|
|
||||||
end
|
end
|
||||||
|
|
11
src/sexp.mli
11
src/sexp.mli
|
@ -65,10 +65,17 @@ module Of_sexp : sig
|
||||||
| Quoted_string of Loc.t * string
|
| Quoted_string of Loc.t * string
|
||||||
| List of Loc.t * ast list
|
| List of Loc.t * ast list
|
||||||
|
|
||||||
|
type hint =
|
||||||
|
{ on: string
|
||||||
|
; candidates: string list
|
||||||
|
}
|
||||||
|
|
||||||
|
exception Of_sexp of Loc.t * string * hint option
|
||||||
|
|
||||||
include Combinators with type 'a t = Ast.t -> 'a
|
include Combinators with type 'a t = Ast.t -> 'a
|
||||||
|
|
||||||
val of_sexp_error : Ast.t -> string -> _
|
val of_sexp_error : ?hint:hint -> Ast.t -> string -> _
|
||||||
val of_sexp_errorf : Ast.t -> ('a, unit, string, 'b) format4 -> 'a
|
val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a
|
||||||
|
|
||||||
val located : 'a t -> (Loc.t * 'a) t
|
val located : 'a t -> (Loc.t * 'a) t
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue