Skip to content

Commit

Permalink
Merge pull request ocaml-ppx#472 from NathanReb/insert-context-free-e…
Browse files Browse the repository at this point in the history 
…xception

Insert caught exception in place of the rewritten or generated item
  • Loading branch information
@NathanReb
NathanReb authored Feb 13, 2024
2 parents 74342e6 + 245db3a commit fe4a387
Show file tree
Hide file tree
Showing 4 changed files with 109 additions and 52 deletions.
3 changes: 3 additions & 0 deletions CHANGES.md
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,9 @@
unreleased
----------

- Insert errors from caught located exceptions in place of the code that
should have been generated by context-free rules. (#472, @NathanReb)

0.32.0 (2024-02-05)
-------------------

Expand Down
107 changes: 83 additions & 24 deletions src/context_free.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -197,6 +197,48 @@ module Generated_code_hook = struct
| _ -> t.f context { loc with loc_start = loc.loc_end } x
end

(* Used to insert error extensions *)
let wrap_extension : type a. loc:Location.t -> a EC.t -> a -> extension -> a =
fun ~loc t original_node extension ->
(* Prefixing constructors with the module path is necessary for OCaml < 4.07,
see https://github.com/ocaml/ocaml/issues/6852 *)
match t with
| EC.Class_expr -> Ast_builder.Default.pcl_extension ~loc extension
| EC.Class_field -> Ast_builder.Default.pcf_extension ~loc extension
| EC.Class_type -> Ast_builder.Default.pcty_extension ~loc extension
| EC.Class_type_field -> Ast_builder.Default.pctf_extension ~loc extension
| EC.Core_type -> Ast_builder.Default.ptyp_extension ~loc extension
| EC.Expression -> Ast_builder.Default.pexp_extension ~loc extension
| EC.Module_expr -> Ast_builder.Default.pmod_extension ~loc extension
| EC.Module_type -> Ast_builder.Default.pmty_extension ~loc extension
| EC.Pattern -> Ast_builder.Default.ppat_extension ~loc extension
| EC.Signature_item -> Ast_builder.Default.psig_extension ~loc extension []
| EC.Structure_item -> Ast_builder.Default.pstr_extension ~loc extension []
| EC.Ppx_import ->
(* Insert the error in the type decl manifest *)
let ptype_manifest =
Some (Ast_builder.Default.ptyp_extension ~loc extension)
in
{ original_node with ptype_manifest }

let exn_to_extension exn =
let error = exn_to_loc_error exn in
let loc = Location.Error.get_location error in
let extension = Location.Error.to_extension error in
(extension, loc)

let exn_to_error_extension context original_node exn =
let extension, loc = exn_to_extension exn in
wrap_extension ~loc context original_node extension

let exn_to_stri exn =
let extension, loc = exn_to_extension exn in
Ast_builder.Default.pstr_extension ~loc extension []

let exn_to_sigi exn =
let extension, loc = exn_to_extension exn in
Ast_builder.Default.psig_extension ~loc extension []

let rec map_node_rec context ts super_call loc base_ctxt x ~embed_errors =
let ctxt =
Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt ()
Expand All @@ -207,7 +249,8 @@ let rec map_node_rec context ts super_call loc base_ctxt x ~embed_errors =
(try
E.For_context.convert_res ts ~ctxt ext
|> With_errors.of_result ~default:None
with exn when embed_errors -> (None, [ exn_to_loc_error exn ]))
with exn when embed_errors ->
With_errors.return (Some (exn_to_error_extension context x exn)))
>>= fun converted ->
match converted with
| None -> super_call base_ctxt x
Expand All @@ -227,7 +270,8 @@ let map_node context ts super_call loc base_ctxt x ~hook ~embed_errors =
(try
E.For_context.convert_res ts ~ctxt ext
|> With_errors.of_result ~default:None
with exn when embed_errors -> (None, [ exn_to_loc_error exn ]))
with exn when embed_errors ->
With_errors.return (Some (exn_to_error_extension context x exn)))
>>= fun converted ->
match converted with
| None -> super_call base_ctxt x
Expand Down Expand Up @@ -261,7 +305,8 @@ let rec map_nodes context ts super_call get_loc base_ctxt l ~hook ~embed_errors
(try
E.For_context.convert_inline_res ts ~ctxt ext
|> With_errors.of_result ~default:None
with exn when embed_errors -> (None, [ exn_to_loc_error exn ]))
with exn when embed_errors ->
With_errors.return (Some [ exn_to_error_extension context x exn ]))
>>= function
| None ->
super_call base_ctxt x >>= fun x ->
Expand Down Expand Up @@ -350,7 +395,7 @@ let context_free_attribute_modification ~loc =
of one element; it only has [@@deriving].
*)
let handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt
~embed_errors =
~embed_errors ~convert_exn =
List.fold_left attrs ~init:(return [])
~f:(fun acc (Rule.Attr_group_inline.T group) ->
acc >>= fun acc ->
Expand All @@ -368,10 +413,12 @@ let handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt
try
let expect_items = group.expand ~ctxt rf expanded_items values in
return (expect_items :: acc)
with exn when embed_errors -> (acc, [ exn_to_loc_error exn ])))
with exn when embed_errors ->
let error_item = [ convert_exn exn ] in
return (error_item :: acc)))

let handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt ~embed_errors
=
let handle_attr_inline attrs ~convert_exn ~item ~expanded_item ~loc ~base_ctxt
~embed_errors =
List.fold_left attrs ~init:(return []) ~f:(fun acc (Rule.Attr_inline.T a) ->
acc >>= fun acc ->
Attribute.get_res a.attribute item |> of_result ~default:None
Expand All @@ -390,7 +437,9 @@ let handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt ~embed_errors
try
let expect_items = a.expand ~ctxt expanded_item value in
return (expect_items :: acc)
with exn when embed_errors -> (acc, [ exn_to_loc_error exn ])))
with exn when embed_errors ->
let error_item = [ convert_exn exn ] in
return (error_item :: acc)))

module Expect_mismatch_handler = struct
type t = {
Expand Down Expand Up @@ -518,7 +567,8 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
| Some pattern -> (
let generated_code =
try return (pattern e)
with exn when embed_errors -> (None, [ exn_to_loc_error exn ])
with exn when embed_errors ->
return (Some (exn_to_error_extension EC.expression e exn))
in
generated_code >>= fun expr ->
match expr with
Expand All @@ -532,18 +582,21 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
| Some pattern -> (
let generated_code =
try return (pattern e)
with exn when embed_errors -> (None, [ exn_to_loc_error exn ])
with exn when embed_errors ->
return (Some (exn_to_error_extension EC.expression e exn))
in
generated_code >>= fun expr ->
match expr with
| None -> super#expression base_ctxt e
| Some e -> self#expression base_ctxt e))
| Pexp_constant (Pconst_integer (s, Some c)) -> (
try expand_constant Integer c s
with exn when embed_errors -> (e, [ exn_to_loc_error exn ]))
with exn when embed_errors ->
return (exn_to_error_extension EC.expression e exn))
| Pexp_constant (Pconst_float (s, Some c)) -> (
try expand_constant Float c s
with exn when embed_errors -> (e, [ exn_to_loc_error exn ]))
with exn when embed_errors ->
return (exn_to_error_extension EC.expression e exn))
| _ -> super#expression base_ctxt e

(* Pre-conditions:
Expand Down Expand Up @@ -688,43 +741,46 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
loop rest ~in_generated_code >>| fun rest -> items @ rest)
| _ -> (
super#structure_item base_ctxt item >>= fun expanded_item ->
let convert_exn = exn_to_stri in
match (item.pstr_desc, expanded_item.pstr_desc) with
| Pstr_type (rf, tds), Pstr_type (exp_rf, exp_tds) ->
(* No context-free rule can rewrite rec flags atm, this
assert acts as a failsafe in case it ever changes *)
assert (Poly.(rf = exp_rf));
handle_attr_group_inline attr_str_type_decls rf ~items:tds
~expanded_items:exp_tds ~loc ~base_ctxt
~expanded_items:exp_tds ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_group_inline attr_str_type_decls_expect rf
~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
| Pstr_modtype mtd, Pstr_modtype exp_mtd ->
handle_attr_inline attr_str_module_type_decls ~item:mtd
~expanded_item:exp_mtd ~loc ~base_ctxt
~expanded_item:exp_mtd ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_str_module_type_decls_expect
~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
| Pstr_typext te, Pstr_typext exp_te ->
handle_attr_inline attr_str_type_exts ~item:te
~expanded_item:exp_te ~loc ~base_ctxt
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_str_type_exts_expect ~item:te
~expanded_item:exp_te ~loc ~base_ctxt
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
| Pstr_exception ec, Pstr_exception exp_ec ->
handle_attr_inline attr_str_exceptions ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_str_exceptions_expect ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
Expand Down Expand Up @@ -783,43 +839,46 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
loop rest ~in_generated_code >>| fun rest -> items @ rest)
| _ -> (
super#signature_item base_ctxt item >>= fun expanded_item ->
let convert_exn = exn_to_sigi in
match (item.psig_desc, expanded_item.psig_desc) with
| Psig_type (rf, tds), Psig_type (exp_rf, exp_tds) ->
(* No context-free rule can rewrite rec flags atm, this
assert acts as a failsafe in case it ever changes *)
assert (Poly.(rf = exp_rf));
handle_attr_group_inline attr_sig_type_decls rf ~items:tds
~expanded_items:exp_tds ~loc ~base_ctxt
~expanded_items:exp_tds ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_group_inline attr_sig_type_decls_expect rf
~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
| Psig_modtype mtd, Psig_modtype exp_mtd ->
handle_attr_inline attr_sig_module_type_decls ~item:mtd
~expanded_item:exp_mtd ~loc ~base_ctxt
~expanded_item:exp_mtd ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_sig_module_type_decls_expect
~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
| Psig_typext te, Psig_typext exp_te ->
handle_attr_inline attr_sig_type_exts ~item:te
~expanded_item:exp_te ~loc ~base_ctxt
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_sig_type_exts_expect ~item:te
~expanded_item:exp_te ~loc ~base_ctxt
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
| Psig_exception ec, Psig_exception exp_ec ->
handle_attr_inline attr_sig_exceptions ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_sig_exceptions_expect ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
Expand Down
3 changes: 1 addition & 2 deletions test/driver/error_embedding/test.t/run.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,8 +8,7 @@ is caught and prepended to the last valid AST

$ echo "let _ = [%raise]" > impl.ml
$ ../raiser.exe -embed-errors impl.ml
[%%ocaml.error "Raising inside the rewriter"]
let _ = [%raise ]
let _ = [%ocaml.error "Raising inside the rewriter"]

The same is true when using the `-as-ppx` mode (note that the error is reported
by ocaml itself)
Expand Down
48 changes: 22 additions & 26 deletions test/driver/exception_handling/run.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -56,11 +56,9 @@ caught, so no AST is produced.

when the -embed-errors flag is passed
$ ./extender.exe -embed-errors impl.ml
[%%ocaml.error "A raised located error"]
[%%ocaml.error "A second raised located error"]
let x = 1 + 1.
let _ = [%gen_raise_located_error ]
let _ = [%gen_raise_located_error2 ]
let _ = [%ocaml.error "A raised located error"]
let _ = [%ocaml.error "A second raised located error"]

In the case of derivers

Expand All @@ -76,11 +74,11 @@ caught, so no AST is produced.

when the -embed-errors flag is passed
$ ./deriver.exe -embed-errors impl.ml
[%%ocaml.error "A raised located error"]
[%%ocaml.error "A second raised located error"]
type a = int
type b = int[@@deriving deriver_located_error]
[%%ocaml.error "A raised located error"]
type c = int[@@deriving deriver_located_error2]
[%%ocaml.error "A second raised located error"]

In the case of whole file transformations:

Expand All @@ -107,11 +105,9 @@ when the -embed-errors flag is not passed

when the -embed-errors flag is passed
$ ./extender.exe -embed-errors impl.ml
[%%ocaml.error "A raised located error"]
[%%ocaml.error "A second raised located error"]
let x = 1 + 1.
let _ = [%gen_raise_located_error ]
let _ = [%gen_raise_located_error2 ]
let _ = [%ocaml.error "A raised located error"]
let _ = [%ocaml.error "A second raised located error"]

In the case of derivers

Expand All @@ -127,12 +123,12 @@ when the -embed-errors flag is not passed
[1]
when the -embed-errors flag is passed
$ ./deriver.exe -embed-errors impl.ml
[%%ocaml.error "A raised located error"]
[%%ocaml.error "A second raised located error"]
let x = 1 + 1.
type a = int
type b = int[@@deriving deriver_located_error]
[%%ocaml.error "A raised located error"]
type b = int[@@deriving deriver_located_error2]
[%%ocaml.error "A second raised located error"]

In the case of whole file transformations:

Expand Down Expand Up @@ -175,16 +171,18 @@ when the -embed-errors flag is not passed

When embed-errors is not passed
$ ./constant_type.exe -embed-errors impl.ml
[%%ocaml.error
"A raised located error in the constant rewriting transformation."]
[%%ocaml.error
"A raised located error in the constant rewriting transformation."]
[%%ocaml.error
"A raised located error in the constant rewriting transformation."]
[%%ocaml.error
"A raised located error in the constant rewriting transformation."]
let x = 2g + 3g
let x = 2g + 3g
let x =
([%ocaml.error
"A raised located error in the constant rewriting transformation."])
+
([%ocaml.error
"A raised located error in the constant rewriting transformation."])
let x =
([%ocaml.error
"A raised located error in the constant rewriting transformation."])
+
([%ocaml.error
"A raised located error in the constant rewriting transformation."])

In the case of Special functions

Expand All @@ -198,10 +196,8 @@ when the -embed-errors flag is not passed

When embed-errors is not passed
$ ./special_functions.exe -embed-errors impl.ml
[%%ocaml.error "error special function"]
[%%ocaml.error "second error special function"]
let x1 = n_args
let x2 = n_args2
let x1 = [%ocaml.error "error special function"]
let x2 = [%ocaml.error "second error special function"]

In the case of whole file transformations:

Expand Down

0 comments on commit fe4a387

Please sign in to comment.