Embed errors in AST instead of raising exceptions

CHANGES.md

@@ -4,6 +4,9 @@
 
 ### Changed
 
+- Insert errors in the AST rather than raising exceptions. This allows
+  merlin to report all ppx_yojson errors at once. (#44, @NathanReb)
+
 ### Deprecated
 
 ### Fixed

dune-project

@@ -1,4 +1,4 @@
-(lang dune 2.7)
+(lang dune 3.10)
 
 (generate_opam_files true)
 

lib/error.ml

@@ -0,0 +1,27 @@
+open Ppxlib
+
+let errorf ~loc message =
+  Location.error_extensionf ~loc "ppx_yojson: %s" message
+
+let unsupported_payload ~loc = errorf ~loc "unsupported payload"
+let unsupported_record_field ~loc = errorf ~loc "unsupported record field"
+
+let too_many_fields_in_record_pattern ~loc =
+  errorf ~loc
+    "record patterns with more than 4 fields aren't supported. Consider using \
+     ppx_deriving_yojson to handle more complex json objects."
+
+let bad_expr_antiquotation_payload ~loc =
+  errorf ~loc "bad antiquotation payload, should be a single expression"
+
+let bad_pat_antiquotation_payload ~loc =
+  errorf ~loc "bad antiquotation payload, should be a pattern"
+
+let invalid_integer_literal_yojson ~loc =
+  errorf ~loc
+    "invalid interger literal. Integer literal should fit within an OCaml int \
+     or be written in decimal form."
+
+let invalid_integer_literal_ezjsonm ~loc =
+  errorf ~loc
+    "invalid interger literal. Integer literal should fit within an OCaml int."

lib/error.mli

@@ -0,0 +1,28 @@
+(** Functions to raise ppx_yojson rewriting errors.
+
+    The [loc] argument should be the loc of the problematic expression within the payload
+    and not the [loc] argument of the [expand] function to provide the user
+    accurate information as to what should be fixed.
+*)
+
+val unsupported_payload : loc:Ppxlib.Location.t -> Ppxlib.extension
+(** Use this for unsupported payload expressions. *)
+
+val unsupported_record_field : loc:Ppxlib.Location.t -> Ppxlib.extension
+(** Use this for unsupported Longident used as record fields. *)
+
+val too_many_fields_in_record_pattern :
+  loc:Ppxlib.Location.t -> Ppxlib.extension
+(** Use this for record pattern with more than 4 fields. *)
+
+val bad_expr_antiquotation_payload : loc:Ppxlib.Location.t -> Ppxlib.extension
+(** Use this for bad payload in expression antiquotation [[%y ...]]. *)
+
+val bad_pat_antiquotation_payload : loc:Ppxlib.Location.t -> Ppxlib.extension
+(** Use this for bad payload in pattern antiquotation [[%y? ...]]. *)
+
+val invalid_integer_literal_yojson : loc:Ppxlib.Location.t -> Ppxlib.extension
+(** Use this for invalid integer literals in the yojson extension *)
+
+val invalid_integer_literal_ezjsonm : loc:Ppxlib.Location.t -> Ppxlib.extension
+(** Use this for invalid integer literals in the ezjsonm extension *)

lib/expression.ml

@@ -4,7 +4,7 @@ module type EXPANDER = sig
   val expand_bool : loc:location -> bool -> expression
   val expand_float : loc:location -> string -> expression
   val expand_int : loc:location -> pexp_loc:location -> string -> expression
-  val expand_intlit : loc:location -> string -> expression
+  val expand_intlit : loc:location -> pexp_loc:location -> string -> expression
   val expand_list : loc:location -> expression list -> expression
   val expand_none : loc:location -> unit -> expression
 
@@ -43,13 +43,17 @@ end
 module Ezjsonm_expander : EXPANDER = struct
   include Common
 
-  let expand_intlit ~loc _ = Raise.unsupported_payload ~loc
+  let expand_intlit ~loc:_ ~pexp_loc:loc _ =
+    Ast_builder.Default.pexp_extension ~loc
+      (Error.invalid_integer_literal_ezjsonm ~loc)
 
   let expand_int ~loc ~pexp_loc s =
     match int_of_string_opt s with
     | Some i ->
         [%expr `Float [%e Ast_builder.Default.efloat ~loc (string_of_int i)]]
-    | _ -> Raise.unsupported_payload ~loc:pexp_loc
+    | _ ->
+        Ast_builder.Default.pexp_extension ~loc:pexp_loc
+          (Error.invalid_integer_literal_ezjsonm ~loc:pexp_loc)
 
   let expand_list ~loc exprs =
     expand_list ~loc (fun e -> [%expr `A [%e e]]) exprs
@@ -61,19 +65,22 @@ end
 module Yojson_expander : EXPANDER = struct
   include Common
 
-  let expand_intlit ~loc s =
+  let expand_intlit ~loc ~pexp_loc:_ s =
     [%expr `Intlit [%e Ast_builder.Default.estring ~loc s]]
 
   let expand_int ~loc ~pexp_loc s =
     match int_of_string_opt s with
     | Some i -> [%expr `Int [%e Ast_builder.Default.eint ~loc i]]
     | None when Integer_const.is_binary s ->
-        Raise.unsupported_payload ~loc:pexp_loc
+        Ast_builder.Default.pexp_extension ~loc:pexp_loc
+          (Error.invalid_integer_literal_yojson ~loc:pexp_loc)
     | None when Integer_const.is_octal s ->
-        Raise.unsupported_payload ~loc:pexp_loc
+        Ast_builder.Default.pexp_extension ~loc:pexp_loc
+          (Error.invalid_integer_literal_yojson ~loc:pexp_loc)
     | None when Integer_const.is_hexadecimal s ->
-        Raise.unsupported_payload ~loc:pexp_loc
-    | None -> expand_intlit ~loc s
+        Ast_builder.Default.pexp_extension ~loc:pexp_loc
+          (Error.invalid_integer_literal_yojson ~loc:pexp_loc)
+    | None -> expand_intlit ~loc ~pexp_loc s
 
   let expand_list ~loc exprs =
     expand_list ~loc (fun e -> [%expr `List [%e e]]) exprs
@@ -86,7 +93,8 @@ module Make (Expander : EXPANDER) = struct
   let expand_anti_quotation ~pexp_loc = function
     | PStr [ { pstr_desc = Pstr_eval (expr, _); _ } ] -> expr
     | PStr _ | PSig _ | PTyp _ | PPat _ ->
-        Raise.bad_expr_antiquotation_payload ~loc:pexp_loc
+        Ast_builder.Default.pexp_extension ~loc:pexp_loc
+          (Error.bad_expr_antiquotation_payload ~loc:pexp_loc)
 
   let rec expand ~loc ~path expr =
     match expr with
@@ -99,9 +107,10 @@ module Make (Expander : EXPANDER) = struct
         Expander.expand_int ~loc ~pexp_loc s
     | {
      pexp_desc = Pexp_constant (Pconst_integer (s, Some ('l' | 'L' | 'n')));
+     pexp_loc;
      _;
     } ->
-        Expander.expand_intlit ~loc s
+        Expander.expand_intlit ~loc ~pexp_loc s
     | { pexp_desc = Pexp_constant (Pconst_float (s, None)); _ } ->
         Expander.expand_float ~loc s
     | [%expr []] -> Expander.expand_list ~loc []
@@ -112,7 +121,9 @@ module Make (Expander : EXPANDER) = struct
     | { pexp_desc = Pexp_extension ({ txt = "y" | "aq"; _ }, p); pexp_loc; _ }
       ->
         expand_anti_quotation ~pexp_loc p
-    | _ -> Raise.unsupported_payload ~loc:expr.pexp_loc
+    | _ ->
+        Ast_builder.Default.pexp_extension ~loc:expr.pexp_loc
+          (Error.unsupported_payload ~loc:expr.pexp_loc)
 
   and expand_list ~loc ~path = function
     | [%expr []] -> []
@@ -124,20 +135,27 @@ module Make (Expander : EXPANDER) = struct
 
   and expand_record ~path l =
     let expand_one (f, e) =
+      let as_attr =
+        List.find_opt
+          (fun attr -> String.equal attr.attr_name.txt "as")
+          e.pexp_attributes
+      in
       let field =
-        match
-          ( List.find_opt
-              (fun attr -> String.equal attr.attr_name.txt "as")
-              e.pexp_attributes,
-            f )
-        with
+        match (as_attr, f) with
         | Some { attr_payload; attr_loc = loc; _ }, _ ->
             Ast_pattern.(parse (single_expr_payload (estring __)))
-              loc attr_payload (fun e -> e)
-        | None, { txt = Lident s; _ } -> Utils.rewrite_field_name s
-        | None, { txt = _; loc } -> Raise.unsupported_record_field ~loc
+              loc attr_payload (fun e -> Ok e)
+        | None, { txt = Lident s; _ } -> Ok (Utils.rewrite_field_name s)
+        | None, { txt = _; loc } ->
+            let extension =
+              Ast_builder.Default.pexp_extension ~loc
+                (Error.unsupported_record_field ~loc)
+            in
+            Error extension
       in
-      (field, expand ~loc:e.pexp_loc ~path e)
+      match field with
+      | Ok field -> (field, expand ~loc:e.pexp_loc ~path e)
+      | Error extension -> ("error", extension)
     in
     List.map expand_one l
 end

lib/pattern.ml

@@ -10,11 +10,14 @@ let expand_int ~loc ~ppat_loc s =
   match int_of_string_opt s with
   | Some i -> [%pat? `Int [%p Ast_builder.Default.pint ~loc i]]
   | None when Integer_const.is_binary s ->
-      Raise.unsupported_payload ~loc:ppat_loc
+      Ast_builder.Default.ppat_extension ~loc:ppat_loc
+        (Error.unsupported_payload ~loc:ppat_loc)
   | None when Integer_const.is_octal s ->
-      Raise.unsupported_payload ~loc:ppat_loc
+      Ast_builder.Default.ppat_extension ~loc:ppat_loc
+        (Error.unsupported_payload ~loc:ppat_loc)
   | None when Integer_const.is_hexadecimal s ->
-      Raise.unsupported_payload ~loc:ppat_loc
+      Ast_builder.Default.ppat_extension ~loc:ppat_loc
+        (Error.unsupported_payload ~loc:ppat_loc)
   | None -> expand_intlit ~loc s
 
 let expand_float ~loc s = [%pat? `Float [%p Ast_builder.Default.pfloat ~loc s]]
@@ -23,7 +26,8 @@ let expand_var ~loc var = Ast_builder.Default.ppat_var ~loc var
 let expand_anti_quotation ~ppat_loc = function
   | PPat (ppat, _) -> ppat
   | PStr _ | PSig _ | PTyp _ ->
-      Raise.bad_pat_antiquotation_payload ~loc:ppat_loc
+      Ast_builder.Default.ppat_extension ~loc:ppat_loc
+        (Error.bad_pat_antiquotation_payload ~loc:ppat_loc)
 
 let rec expand ~loc ~path pat =
   match pat with
@@ -54,7 +58,8 @@ let rec expand ~loc ~path pat =
   | [%pat? [%p? _] :: [%p? _]] -> [%pat? `List [%p expand_list ~loc ~path pat]]
   | { ppat_desc = Ppat_record (l, Closed); ppat_loc; _ } ->
       expand_record ~loc ~ppat_loc ~path l
-  | { ppat_loc = loc; _ } -> Raise.unsupported_payload ~loc
+  | { ppat_loc = loc; _ } ->
+      Ast_builder.Default.ppat_extension ~loc (Error.unsupported_payload ~loc)
 
 and expand_list ~loc ~path = function
   | [%pat? []] -> [%pat? []]
@@ -66,27 +71,36 @@ and expand_list ~loc ~path = function
 
 and expand_record ~loc ~ppat_loc ~path l =
   let expand_one (f, p) =
+    let as_attr =
+      List.find_opt
+        (fun attr -> String.equal attr.attr_name.txt "as")
+        p.ppat_attributes
+    in
     let field =
-      match
-        ( List.find_opt
-            (fun attr -> String.equal attr.attr_name.txt "as")
-            p.ppat_attributes,
-          f )
-      with
+      match (as_attr, f) with
       | Some { attr_payload; attr_loc = loc; _ }, _ ->
           Ast_pattern.(parse (single_expr_payload (estring __)))
-            loc attr_payload (fun e -> e)
-      | None, { txt = Lident s; _ } -> Utils.rewrite_field_name s
-      | None, { txt = _; loc } -> Raise.unsupported_record_field ~loc
+            loc attr_payload (fun e -> Ok e)
+      | None, { txt = Lident s; _ } -> Ok (Utils.rewrite_field_name s)
+      | None, { txt = _; loc } ->
+          let pat_ext =
+            Ast_builder.Default.ppat_extension ~loc
+              (Error.unsupported_record_field ~loc)
+          in
+          Error pat_ext
     in
-    [%pat?
-      [%p Ast_builder.Default.pstring ~loc field], [%p expand ~loc ~path p]]
+    match field with
+    | Ok field ->
+        [%pat?
+          [%p Ast_builder.Default.pstring ~loc field], [%p expand ~loc ~path p]]
+    | Error extension -> extension
   in
   let assoc_pattern pat_list =
     [%pat? `Assoc [%p Ast_builder.Default.plist ~loc pat_list]]
   in
   if List.length l > 4 then
-    Raise.too_many_fields_in_record_pattern ~loc:ppat_loc
+    Ast_builder.Default.ppat_extension ~loc:ppat_loc
+      (Error.too_many_fields_in_record_pattern ~loc:ppat_loc)
   else
     let pat_list = List.map expand_one l in
     let permutations = Utils.permutations pat_list in

ppx_yojson.opam

@@ -7,7 +7,7 @@ license: "BSD-2-Clause"
 homepage: "https://github.com/NathanReb/ppx_yojson"
 bug-reports: "https://github.com/NathanReb/ppx_yojson/issues"
 depends: [
-  "dune" {>= "2.7"}
+  "dune" {>= "3.10"}
   "ocaml" {>= "4.08"}
   "alcotest" {with-test}
   "ppxlib" {>= "0.18.0"}

test/rewriter/errors/dune

@@ -1,15 +1,3 @@
-(include dune.inc)
-
-(rule
- (targets dune.inc.gen)
+(cram
  (deps
-  (source_tree .))
- (action
-  (with-stdout-to
-   %{targets}
-   (run ./bin/gen_dune_rules.exe))))
-
-(rule
- (alias runtest)
- (action
-  (diff dune.inc dune.inc.gen)))
+  (package ppx_yojson)))