Decouple hint handling in sexp parser from Import

src/report_error.ml

@@ -33,6 +33,19 @@ let report_with_backtrace exn =
       in
       let pp ppf = Format.fprintf ppf "@{<error>Error@}: %s\n" msg in
       { 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 ->
       let pos = Usexp.Parser.Error.position e in
       let msg = Usexp.Parser.Error.message e in

src/sexp.ml

@@ -122,13 +122,20 @@ module Of_sexp = struct
     | Quoted_string of Loc.t * string
     | 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
 
   let located f sexp =
     (Ast.loc sexp, f sexp)
 
-  let of_sexp_error sexp str = raise (Loc.Error (Ast.loc sexp, str))
-  let of_sexp_errorf sexp fmt = ksprintf (of_sexp_error sexp) fmt
+  let of_sexp_error ?hint sexp str = raise (Of_sexp (Ast.loc sexp, str, hint))
+  let of_sexp_errorf ?hint sexp fmt = ksprintf (of_sexp_error ?hint sexp) fmt
 
   let raw x = x
 
@@ -338,8 +345,8 @@ module Of_sexp = struct
         | List (_, s :: _) -> s
         | _ -> assert false
       in
-      of_sexp_errorf name_sexp
-        "Unknown field %s%s" name (hint name state.known)
+      of_sexp_errorf ~hint:({ on = name ; candidates = state.known})
+        name_sexp "Unknown field %s" name
 
   type ('a, 'b) rest =
     | No_rest : ('a, 'a) rest
@@ -413,11 +420,11 @@ module Of_sexp = struct
     | Some cstr -> cstr
     | None ->
       of_sexp_errorf sexp
-        "Unknown constructor %s%s" name
-        (hint
-           (String.uncapitalize name)
-           (List.map cstrs ~f:(fun c ->
-              String.uncapitalize (C.name c))))
+        ~hint:{ on = String.uncapitalize name
+              ; candidates = List.map cstrs ~f:(fun c ->
+                  String.uncapitalize (C.name c))
+              }
+        "Unknown constructor %s" name
 
   let sum cstrs sexp =
     match sexp with
@@ -447,9 +454,8 @@ module Of_sexp = struct
       | Some (_, value) -> value
       | None ->
         of_sexp_errorf sexp
-          "Unknown value %s%s" s
-          (hint
-             (String.uncapitalize s)
-             (List.map cstrs ~f:(fun (name, _) ->
-                String.uncapitalize name)))
+          ~hint:{ on = String.uncapitalize s
+                ; candidates =List.map cstrs ~f:(fun (name, _) ->
+                    String.uncapitalize name) }
+          "Unknown value %s" s
 end

src/sexp.mli

@@ -65,10 +65,17 @@ module Of_sexp : sig
     | Quoted_string of Loc.t * string
     | 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
 
-  val of_sexp_error  : Ast.t -> string -> _
-  val of_sexp_errorf : Ast.t -> ('a, unit, string, 'b) format4 -> 'a
+  val of_sexp_error  : ?hint:hint -> Ast.t -> string -> _
+  val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a
 
   val located : 'a t -> (Loc.t * 'a) t