Add flag -raise-embedded-errors to Driver, which raises the first embedded ocaml.error in the processed AST.

Signed-off-by: Jay Mody <[email protected]>

Author: jaymody

Diff for: ast/location_error.ml

@@ -40,3 +40,33 @@ let get_location error =
 
 let of_exn = Astlib.Location.Error.of_exn
 let raise error = raise (Astlib.Location.Error error)
+
+let of_extension (extension : Ast.extension) =
+  let open Parsetree in
+  let parse_msg = function
+    | {
+        pstr_desc =
+          Pstr_eval
+            ({ pexp_desc = Pexp_constant (Pconst_string (msg, _, _)); _ }, []);
+        _;
+      } ->
+        msg
+    | _ -> "ppxlib: failed to extract message in ocaml.error"
+  in
+  let parse_sub_msg = function
+    | {
+        pstr_desc =
+          Pstr_extension
+            (({ txt = "error" | "ocaml.error"; loc }, PStr [ msg ]), []);
+        _;
+      } ->
+        (loc, parse_msg msg)
+    | { pstr_loc = loc; _ } ->
+        (loc, "ppxlib: failed to parse ocaml.error sub messages")
+  in
+  match extension with
+  | { txt = "error" | "ocaml.error"; loc }, PStr (main :: sub) ->
+      let main = parse_msg main in
+      let sub = List.map parse_sub_msg sub in
+      Some (make ~loc main ~sub)
+  | _ -> None

Diff for: ast/location_error.mli

@@ -11,3 +11,4 @@ val to_extension : t -> Import.Parsetree.extension
 val raise : t -> 'a
 val update_loc : t -> Location.t -> t
 val get_location : t -> Location.t
+val of_extension : Import.Parsetree.extension -> t option

Diff for: src/driver.ml

@@ -25,13 +25,25 @@ let styler = ref None
 let output_metadata_filename = ref None
 let corrected_suffix = ref ".ppx-corrected"
 let keywords = ref None
+let raise_embedded_errors_flag = ref false
 
 let ghost =
   object
     inherit Ast_traverse.map
     method! location loc = { loc with loc_ghost = true }
   end
 
+let raise_embedded_errors =
+  object
+    inherit Ast_traverse.map as super
+
+    method! extension extension =
+      if !raise_embedded_errors_flag then
+        extension |> Location.Error.of_extension
+        |> Option.iter ~f:Location.Error.raise;
+      super#extension extension
+  end
+
 let chop_prefix ~prefix x =
   if String.is_prefix ~prefix x then
     Some (String.drop_prefix x (String.length prefix))
@@ -696,7 +708,9 @@ let map_structure_gen st ~tool_name ~hook ~expect_mismatch_handler ~input_name
       ~dropped_so_far:Attribute.dropped_so_far_structure ~hook
       ~expect_mismatch_handler ~input_name ~embed_errors
   in
-  st |> lint lint_errors |> cookies_and_check |> with_errors (List.rev errors)
+  st |> lint lint_errors |> cookies_and_check
+  |> with_errors (List.rev errors)
+  |> raise_embedded_errors#structure
 
 let map_structure st =
   match
@@ -772,7 +786,9 @@ let map_signature_gen sg ~tool_name ~hook ~expect_mismatch_handler ~input_name
       ~dropped_so_far:Attribute.dropped_so_far_signature ~hook
       ~expect_mismatch_handler ~input_name ~embed_errors
   in
-  sg |> lint lint_errors |> cookies_and_check |> with_errors (List.rev errors)
+  sg |> lint lint_errors |> cookies_and_check
+  |> with_errors (List.rev errors)
+  |> raise_embedded_errors#signature
 
 let map_signature sg =
   match
@@ -1320,6 +1336,9 @@ let shared_args =
        applied before all impl and intf." );
     ("-cookie", Arg.String set_cookie, "NAME=EXPR Set the cookie NAME to EXPR");
     ("--cookie", Arg.String set_cookie, " Same as -cookie");
+    ( "-raise-embedded-errors",
+      Arg.Set raise_embedded_errors_flag,
+      " Raise the first embedded error found in the processed AST" );
   ]
 
 let () =

Diff for: src/location.mli

@@ -87,6 +87,10 @@ module Error : sig
 
   val get_location : t -> location
   (** Find out where the error is located. *)
+
+  val of_extension : extension -> t option
+  (** Convert an extension point to an error. Extension points must have the
+      exact form as created by [to_extension]. *)
 end
 with type location := t
 

Diff for: test/driver/run_as_ppx_rewriter/run.t

@@ -63,6 +63,7 @@ The only possible usage is [extra_args] <infile> <outfile>...
     -no-merge                   Do not merge context free transformations (better for debugging rewriters). As a result, the context-free transformations are not all applied before all impl and intf.
     -cookie NAME=EXPR           Set the cookie NAME to EXPR
     --cookie                    Same as -cookie
+    -raise-embedded-errors      Raise the first embedded error found in the processed AST
     -help                       Display this list of options
     --help                      Display this list of options
   [2]
@@ -84,5 +85,6 @@ The only exception is consulting help
     -no-merge                   Do not merge context free transformations (better for debugging rewriters). As a result, the context-free transformations are not all applied before all impl and intf.
     -cookie NAME=EXPR           Set the cookie NAME to EXPR
     --cookie                    Same as -cookie
+    -raise-embedded-errors      Raise the first embedded error found in the processed AST
     -help                       Display this list of options
     --help                      Display this list of options

Diff for: test/error_embedding/run.t

@@ -75,3 +75,15 @@ Error nodes are generated when dependent derivers are not applied.
       let _ = "derived_string"
       let _ = "derived_string"
     end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+Flag `-raise-embedded-errors` raises the first embedded error in the AST.
+
+  $ echo "let () = ()" > embedded_error.ml
+  $ echo "module _ = struct [%%ocaml.error \"error 1\"] end" >> embedded_error.ml
+  $ echo "[%%ocaml.error \"error 2\"]" >> embedded_error.ml
+  $ ./extender.exe embedded_error.ml -raise-embedded-errors
+  File "embedded_error.ml", line 2, characters 21-32:
+  2 | module _ = struct [%%ocaml.error "error 1"] end
+                           ^^^^^^^^^^^
+  Error: error 1
+  [1]