Insert error extension nodes instead of raising exceptions

Signed-off-by: Nathan Rebours <nathan.p.rebours@gmail.com>

Author: NathanReb

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

@@ -30,3 +30,5 @@
    (and
     :with-test
     (>= 1.6.0)))))
+
+(cram enable)

lib/raise.ml lib/error.mllib/raise.ml renamed to lib/error.ml

@@ -1,18 +1,20 @@
+open Ppxlib
+
 let unsupported_payload ~loc =
-  Location.raise_errorf ~loc "ppx_yojson: unsupported payload"
+  Location.error_extensionf ~loc "ppx_yojson: unsupported payload"
 
 let unsupported_record_field ~loc =
-  Location.raise_errorf ~loc "ppx_yojson: unsupported record field"
+  Location.error_extensionf ~loc "ppx_yojson: unsupported record field"
 
 let too_many_fields_in_record_pattern ~loc =
-  Location.raise_errorf ~loc
+  Location.error_extensionf ~loc
     "ppx_yojson: 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 =
-  Location.raise_errorf ~loc
+  Location.error_extensionf ~loc
     "ppx_yojson: bad antiquotation payload, should be a single expression"
 
 let bad_pat_antiquotation_payload ~loc =
-  Location.raise_errorf ~loc
+  Location.error_extensionf ~loc
     "ppx_yojson: bad antiquotation payload, should be a pattern"

lib/raise.mli lib/error.mlilib/raise.mli renamed to lib/error.mli

@@ -5,17 +5,18 @@
     accurate information as to what should be fixed.
 *)
 
-val unsupported_payload : loc:Ppxlib.Location.t -> 'a
+val unsupported_payload : loc:Ppxlib.Location.t -> Ppxlib.extension
 (** Use this for unsupported payload expressions. *)
 
-val unsupported_record_field : loc:Ppxlib.Location.t -> 'a
+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 -> 'a
+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 -> 'a
+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 -> 'a
+val bad_pat_antiquotation_payload : loc:Ppxlib.Location.t -> Ppxlib.extension
 (** Use this for bad payload in pattern antiquotation [[%y? ...]]. *)

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,16 @@ 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.unsupported_payload ~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.unsupported_payload ~loc:pexp_loc)
 
   let expand_list ~loc exprs =
     expand_list ~loc (fun e -> [%expr `A [%e e]]) exprs
@@ -61,19 +64,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.unsupported_payload ~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.unsupported_payload ~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.unsupported_payload ~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 +92,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 +106,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 +120,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 +134,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

test/rewriter/errors/bin/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)))