diff --git a/ast/location_error.ml b/ast/location_error.ml index db8f77f3..0b70257e 100644 --- a/ast/location_error.ml +++ b/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 --git a/ast/location_error.mli b/ast/location_error.mli index 0a6c96a7..fbe3a397 100644 --- a/ast/location_error.mli +++ b/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 --git a/src/driver.ml b/src/driver.ml index 4e7e7e88..34de4b69 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -25,6 +25,7 @@ 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 @@ -32,6 +33,17 @@ let ghost = 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 --git a/src/location.mli b/src/location.mli index 47c8d4dc..9236d64f 100644 --- a/src/location.mli +++ b/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 --git a/test/driver/run_as_ppx_rewriter/run.t b/test/driver/run_as_ppx_rewriter/run.t index 0befcacb..a9a0d715 100644 --- a/test/driver/run_as_ppx_rewriter/run.t +++ b/test/driver/run_as_ppx_rewriter/run.t @@ -63,6 +63,7 @@ The only possible usage is [extra_args] ... -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 --git a/test/error_embedding/run.t b/test/error_embedding/run.t index 998f19e2..fa7b2744 100644 --- a/test/error_embedding/run.t +++ b/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]