From c82fedf26deb86c91cec665bbe40fdc61df5afc6 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Thu, 3 Aug 2023 14:58:13 +0100 Subject: [PATCH 01/20] Allowing multiple errors to be reported in one pass of the context_free transformation. Signed-off-by: Burnleydev1 --- src/context_free.ml | 23 ++++++++++++++++------ test/driver/exception_handling/extender.ml | 9 +++++++++ test/driver/exception_handling/run.t | 14 ++++++++++--- 3 files changed, 37 insertions(+), 9 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index 35e03dfba..633814881 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -197,6 +197,11 @@ module Generated_code_hook = struct | _ -> t.f context { loc with loc_start = loc.loc_end } x end +let exn_to_error exn = + match Location.Error.of_exn exn with None -> raise exn | Some error -> error + +let errors = [] + let rec map_node_rec context ts super_call loc base_ctxt x = let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () @@ -204,8 +209,10 @@ let rec map_node_rec context ts super_call loc base_ctxt x = match EC.get_extension context x with | None -> super_call base_ctxt x | Some (ext, attrs) -> ( - E.For_context.convert_res ts ~ctxt ext - |> With_errors.of_result ~default:None + (try + E.For_context.convert_res ts ~ctxt ext + |> With_errors.of_result ~default:None + with exn -> (None, exn_to_error exn :: errors)) >>= fun converted -> match converted with | None -> super_call base_ctxt x @@ -221,8 +228,10 @@ let map_node context ts super_call loc base_ctxt x ~hook = match EC.get_extension context x with | None -> super_call base_ctxt x | Some (ext, attrs) -> ( - E.For_context.convert_res ts ~ctxt ext - |> With_errors.of_result ~default:None + (try + E.For_context.convert_res ts ~ctxt ext + |> With_errors.of_result ~default:None + with exn -> (None, exn_to_error exn :: errors)) >>= fun converted -> match converted with | None -> super_call base_ctxt x @@ -252,8 +261,10 @@ let rec map_nodes context ts super_call get_loc base_ctxt l ~hook Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in - E.For_context.convert_inline_res ts ~ctxt ext - |> With_errors.of_result ~default:None + (try + E.For_context.convert_inline_res ts ~ctxt ext + |> With_errors.of_result ~default:None + with exn -> (None, exn_to_error exn :: errors)) >>= function | None -> super_call base_ctxt x >>= fun x -> diff --git a/test/driver/exception_handling/extender.ml b/test/driver/exception_handling/extender.ml index eda39c0ea..b4a6549f0 100644 --- a/test/driver/exception_handling/extender.ml +++ b/test/driver/exception_handling/extender.ml @@ -13,6 +13,10 @@ let expand_raise_located_error ~ctxt = let loc = Expansion_context.Extension.extension_point_loc ctxt in Location.raise_errorf ~loc "A raised located error" +let expand2_raise_located_error ~ctxt = + let loc = Expansion_context.Extension.extension_point_loc ctxt in + Location.raise_errorf ~loc "A second raised located error" + let extension_point_extension = Extension.V3.declare "gen_ext_node" Extension.Context.expression Ast_pattern.(pstr nil) @@ -28,6 +32,11 @@ let raise_located_error_extension = Ast_pattern.(pstr nil) expand_raise_located_error +let raise2_located_error_extension = + Extension.V3.declare "gen2_raise_located_error" Extension.Context.expression + Ast_pattern.(pstr nil) + expand2_raise_located_error + let rule1 = Ppxlib.Context_free.Rule.extension extension_point_extension let rule2 = Ppxlib.Context_free.Rule.extension raise_exception_extension let rule3 = Ppxlib.Context_free.Rule.extension raise_located_error_extension diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 5d3caba75..0807a8f0b 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -44,16 +44,19 @@ caught, so no AST is produced. $ echo "let x = 1+1. " > impl.ml $ echo "let _ = [%gen_raise_located_error]" >> impl.ml + $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml $ export OCAML_ERROR_STYLE=short $ ./extender.exe impl.ml - File "impl.ml", line 2, characters 8-34: - Error: A raised located error - [1] + [%%ocaml.error "A raised located error"] + let x = 1 + 1. + let _ = [%gen_raise_located_error ] + let _ = [%gen2_raise_located_error ] In the case of derivers $ echo "type a = int" > impl.ml $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml + $ echo "type b = int [@@deriving deriver2_located_error]" >> impl.ml $ ./deriver.exe impl.ml File "impl.ml", line 2, characters 0-47: Error: A raised located error @@ -74,20 +77,24 @@ and the whole AST is prepended with an error extension node. $ echo "let x = 1+1. " > impl.ml $ echo "let _ = [%gen_raise_located_error]" >> impl.ml + $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml $ ./extender.exe -embed-errors impl.ml [%%ocaml.error "A raised located error"] let x = 1 + 1. let _ = [%gen_raise_located_error ] + let _ = [%gen2_raise_located_error ] In the case of derivers $ echo "let x = 1+1. " > impl.ml $ echo "type a = int" > impl.ml $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml + $ echo "type c = int [@@deriving deriver2_located_error]" >> impl.ml $ ./deriver.exe -embed-errors impl.ml [%%ocaml.error "A raised located error"] type a = int type b = int[@@deriving deriver_located_error] + type c = int[@@deriving deriver2_located_error] In the case of whole file transformations: @@ -112,6 +119,7 @@ and the whole AST is prepended with an error extension node. $ echo "type a = int" > impl.ml $ echo "type b = int [@@deriving deriver_raised_exception]" >> impl.ml + $ echo "type c = int [@@deriving deriver2_located_error]" >> impl.ml $ ./deriver.exe -embed-errors impl.ml Fatal error: exception Failure("A raised exception") [2] From 637bef7fc2010cf78b71929973fcbac01a0541fd Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Thu, 3 Aug 2023 15:03:28 +0100 Subject: [PATCH 02/20] minor updates Signed-off-by: Burnleydev1 --- test/driver/exception_handling/extender.ml | 5 ++++- test/driver/exception_handling/run.t | 2 ++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/test/driver/exception_handling/extender.ml b/test/driver/exception_handling/extender.ml index b4a6549f0..e0537ccc2 100644 --- a/test/driver/exception_handling/extender.ml +++ b/test/driver/exception_handling/extender.ml @@ -40,8 +40,11 @@ let raise2_located_error_extension = let rule1 = Ppxlib.Context_free.Rule.extension extension_point_extension let rule2 = Ppxlib.Context_free.Rule.extension raise_exception_extension let rule3 = Ppxlib.Context_free.Rule.extension raise_located_error_extension +let rule4 = Ppxlib.Context_free.Rule.extension raise2_located_error_extension let () = - Driver.register_transformation ~rules:[ rule1; rule2; rule3 ] "gen_errors" + Driver.register_transformation + ~rules:[ rule1; rule2; rule3; rule4 ] + "gen_errors" let () = Driver.standalone () diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 0807a8f0b..fb907d375 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -48,6 +48,7 @@ caught, so no AST is produced. $ export OCAML_ERROR_STYLE=short $ ./extender.exe 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 _ = [%gen2_raise_located_error ] @@ -80,6 +81,7 @@ and the whole AST is prepended with an error extension node. $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml $ ./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 _ = [%gen2_raise_located_error ] From 5e45c0562e97600b01c33679cb9a8586d56216f3 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Fri, 4 Aug 2023 08:36:10 +0100 Subject: [PATCH 03/20] add changlog Signed-off-by: Burnleydev1 --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 024836b9f..12859645d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,8 @@ unreleased ------------------- +- Allowing multiple errors to be reported in one pass of the context_free transformation.(#453, @burnleydev1) + - Sort embedded errors that are appended to the AST by location so the compiler reports the one closer to the beginning of the file first. (#463, @NathanReb) From f513df0b7611968eece2f4bb5ce76faa0046c13d Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Fri, 4 Aug 2023 11:43:53 +0100 Subject: [PATCH 04/20] Added -embed-error flag Signed-off-by: Burnleydev1 --- src/context_free.ml | 50 +++++++++++++++------------- test/driver/exception_handling/run.t | 9 ++--- 2 files changed, 30 insertions(+), 29 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index 633814881..b92b3bb62 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -200,9 +200,7 @@ end let exn_to_error exn = match Location.Error.of_exn exn with None -> raise exn | Some error -> error -let errors = [] - -let rec map_node_rec context ts super_call loc base_ctxt x = +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 () in @@ -212,16 +210,17 @@ let rec map_node_rec context ts super_call loc base_ctxt x = (try E.For_context.convert_res ts ~ctxt ext |> With_errors.of_result ~default:None - with exn -> (None, exn_to_error exn :: errors)) + with exn when embed_errors -> (None, [ exn_to_error exn ])) >>= fun converted -> match converted with | None -> super_call base_ctxt x | Some x -> EC.merge_attributes_res context x attrs |> With_errors.of_result ~default:x - >>= fun x -> map_node_rec context ts super_call loc base_ctxt x) + >>= fun x -> + map_node_rec context ts super_call loc base_ctxt x ~embed_errors) -let map_node context ts super_call loc base_ctxt x ~hook = +let map_node context ts super_call loc base_ctxt x ~hook ~embed_errors = let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () in @@ -231,18 +230,19 @@ let map_node context ts super_call loc base_ctxt x ~hook = (try E.For_context.convert_res ts ~ctxt ext |> With_errors.of_result ~default:None - with exn -> (None, exn_to_error exn :: errors)) + with exn when embed_errors -> (None, [ exn_to_error exn ])) >>= fun converted -> match converted with | None -> super_call base_ctxt x | Some x -> map_node_rec context ts super_call loc base_ctxt (EC.merge_attributes context x attrs) + ~embed_errors >>| fun generated_code -> Generated_code_hook.replace hook context loc (Single generated_code); generated_code) -let rec map_nodes context ts super_call get_loc base_ctxt l ~hook +let rec map_nodes context ts super_call get_loc base_ctxt l ~hook ~embed_errors ~in_generated_code = match l with | [] -> return [] @@ -253,7 +253,7 @@ let rec map_nodes context ts super_call get_loc base_ctxt l ~hook same order as they appear in the source file. *) super_call base_ctxt x >>= fun x -> map_nodes context ts super_call get_loc base_ctxt l ~hook - ~in_generated_code + ~embed_errors ~in_generated_code >>| fun l -> x :: l | Some (ext, attrs) -> ( let extension_point_loc = get_loc x in @@ -264,23 +264,23 @@ let rec map_nodes context ts super_call get_loc base_ctxt l ~hook (try E.For_context.convert_inline_res ts ~ctxt ext |> With_errors.of_result ~default:None - with exn -> (None, exn_to_error exn :: errors)) + with exn when embed_errors -> (None, [ exn_to_error exn ])) >>= function | None -> super_call base_ctxt x >>= fun x -> map_nodes context ts super_call get_loc base_ctxt l ~hook - ~in_generated_code + ~embed_errors ~in_generated_code >>| fun l -> x :: l | Some converted -> ((), attributes_errors attrs) >>= fun () -> map_nodes context ts super_call get_loc base_ctxt converted ~hook - ~in_generated_code:true + ~embed_errors ~in_generated_code:true >>= fun generated_code -> if not in_generated_code then Generated_code_hook.replace hook context extension_point_loc (Many generated_code); map_nodes context ts super_call get_loc base_ctxt l ~hook - ~in_generated_code + ~embed_errors ~in_generated_code >>| fun code -> generated_code @ code)) let map_nodes = map_nodes ~in_generated_code:false @@ -470,9 +470,11 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) method! core_type base_ctxt x = map_node EC.core_type core_type super#core_type x.ptyp_loc base_ctxt x + ~embed_errors:false method! pattern base_ctxt x = map_node EC.pattern pattern super#pattern x.ppat_loc base_ctxt x + ~embed_errors:false method! expression base_ctxt e = let with_context = @@ -495,7 +497,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | Pexp_extension _ -> map_node EC.expression expression (fun _ e -> return e) - e.pexp_loc base_ctxt e + e.pexp_loc base_ctxt e ~embed_errors:false | _ -> return e in expanded >>= fun e -> @@ -561,21 +563,23 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) method! class_type base_ctxt x = map_node EC.class_type class_type super#class_type x.pcty_loc base_ctxt x + ~embed_errors:false method! class_type_field base_ctxt x = map_node EC.class_type_field class_type_field super#class_type_field - x.pctf_loc base_ctxt x + x.pctf_loc base_ctxt x ~embed_errors:false method! class_expr base_ctxt x = map_node EC.class_expr class_expr super#class_expr x.pcl_loc base_ctxt x + ~embed_errors:false method! class_field base_ctxt x = map_node EC.class_field class_field super#class_field x.pcf_loc base_ctxt - x + x ~embed_errors:false method! module_type base_ctxt x = map_node EC.module_type module_type super#module_type x.pmty_loc base_ctxt - x + x ~embed_errors:false method! module_expr base_ctxt x = ((* Make sure code-path attribute is applied before expanding. *) @@ -591,32 +595,32 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) (Expansion_context.Base.enter_module ~loc txt base_ctxt, x)) >>= fun (base_ctxt, x) -> map_node EC.module_expr module_expr super#module_expr x.pmod_loc base_ctxt - x + x ~embed_errors:false method! structure_item base_ctxt x = map_node EC.structure_item structure_item super#structure_item x.pstr_loc - base_ctxt x + base_ctxt x ~embed_errors:false method! signature_item base_ctxt x = map_node EC.signature_item signature_item super#signature_item x.psig_loc - base_ctxt x + base_ctxt x ~embed_errors:false method! class_structure base_ctxt { pcstr_self; pcstr_fields } = self#pattern base_ctxt pcstr_self >>= fun pcstr_self -> map_nodes EC.class_field class_field super#class_field (fun x -> x.pcf_loc) - base_ctxt pcstr_fields + base_ctxt pcstr_fields ~embed_errors:false >>| fun pcstr_fields -> { pcstr_self; pcstr_fields } method! type_declaration base_ctxt x = map_node EC.Ppx_import ppx_import super#type_declaration x.ptype_loc - base_ctxt x + base_ctxt x ~embed_errors:false method! class_signature base_ctxt { pcsig_self; pcsig_fields } = self#core_type base_ctxt pcsig_self >>= fun pcsig_self -> map_nodes EC.class_type_field class_type_field super#class_type_field (fun x -> x.pctf_loc) - base_ctxt pcsig_fields + base_ctxt pcsig_fields ~embed_errors:false >>| fun pcsig_fields -> { pcsig_self; pcsig_fields } (* TODO: try to factorize #structure and #signature without meta-programming *) diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index fb907d375..e63cd2f9d 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -47,11 +47,9 @@ caught, so no AST is produced. $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml $ export OCAML_ERROR_STYLE=short $ ./extender.exe 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 _ = [%gen2_raise_located_error ] + File "impl.ml", line 2, characters 8-34: + Error: A raised located error + [1] In the case of derivers @@ -81,7 +79,6 @@ and the whole AST is prepended with an error extension node. $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml $ ./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 _ = [%gen2_raise_located_error ] From 263f8b611d51098e7fd425123b3ac3ed55889724 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Fri, 4 Aug 2023 12:30:23 +0100 Subject: [PATCH 05/20] improving errors in the context-free phase: Deriver Signed-off-by: Burnleydev1 --- src/context_free.ml | 48 +++++++++++++++++----------- test/driver/exception_handling/run.t | 34 ++++++++++++++++++++ 2 files changed, 64 insertions(+), 18 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index b92b3bb62..549f9ca42 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -352,7 +352,8 @@ let context_free_attribute_modification ~loc = This complexity is horrible, but in practice we don't care as [attrs] is always a list of one element; it only has [@@deriving]. *) -let handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt = +let handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt + ~embed_errors = List.fold_left attrs ~init:(return []) ~f:(fun acc (Rule.Attr_group_inline.T group) -> acc >>= fun acc -> @@ -362,15 +363,18 @@ let handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt = | None, None -> return acc | None, Some _ | Some _, None -> context_free_attribute_modification ~loc |> of_result ~default:acc - | Some values, Some _ -> + | Some values, Some _ -> ( let ctxt = Expansion_context.Deriver.make ~derived_item_loc:loc ~inline:group.expect ~base:base_ctxt () in - let expect_items = group.expand ~ctxt rf expanded_items values in - return (expect_items :: acc)) + try + let expect_items = group.expand ~ctxt rf expanded_items values in + return (expect_items :: acc) + with exn when embed_errors -> (acc, [ exn_to_error exn ]))) -let handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt = +let handle_attr_inline attrs ~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 @@ -381,13 +385,15 @@ let handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt = | None, None -> return acc | None, Some _ | Some _, None -> context_free_attribute_modification ~loc |> of_result ~default:acc - | Some value, Some _ -> + | Some value, Some _ -> ( let ctxt = Expansion_context.Deriver.make ~derived_item_loc:loc ~inline:a.expect ~base:base_ctxt () in - let expect_items = a.expand ~ctxt expanded_item value in - return (expect_items :: acc)) + try + let expect_items = a.expand ~ctxt expanded_item value in + return (expect_items :: acc) + with exn when embed_errors -> (acc, [ exn_to_error exn ]))) module Expect_mismatch_handler = struct type t = { @@ -680,36 +686,39 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) assert (Poly.(rf = exp_rf)); handle_attr_group_inline attr_str_type_decls rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + ~embed_errors:false >>= fun extra_items -> handle_attr_group_inline attr_str_type_decls_expect rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + ~embed_errors:false >>= 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 ~embed_errors:false >>= fun extra_items -> handle_attr_inline attr_str_module_type_decls_expect ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt + ~embed_errors:false >>= 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 ~embed_errors:false >>= 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 ~embed_errors:false >>= 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 ~embed_errors:false >>= 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 ~embed_errors:false >>= fun expect_items -> with_extra_items expanded_item ~extra_items ~expect_items ~rest ~in_generated_code @@ -775,36 +784,39 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) assert (Poly.(rf = exp_rf)); handle_attr_group_inline attr_sig_type_decls rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + ~embed_errors:false >>= fun extra_items -> handle_attr_group_inline attr_sig_type_decls_expect rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + ~embed_errors:false >>= 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 ~embed_errors:false >>= fun extra_items -> handle_attr_inline attr_sig_module_type_decls_expect ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt + ~embed_errors:false >>= 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 ~embed_errors:false >>= 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 ~embed_errors:false >>= 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 ~embed_errors:false >>= 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 ~embed_errors:false >>= fun expect_items -> with_extra_items expanded_item ~extra_items ~expect_items ~rest ~in_generated_code diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index e63cd2f9d..3240c756d 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -46,21 +46,40 @@ caught, so no AST is produced. $ echo "let _ = [%gen_raise_located_error]" >> impl.ml $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml $ export OCAML_ERROR_STYLE=short + + when the -embed-errors flag is not passed $ ./extender.exe impl.ml File "impl.ml", line 2, characters 8-34: Error: A raised located error [1] + + when the -embed-errors flag is passed + $ ./extender.exe -embed-errors impl.ml + [%%ocaml.error "A raised located error"] + let x = 1 + 1. + let _ = [%gen_raise_located_error ] + let _ = [%gen2_raise_located_error ] + In the case of derivers $ echo "type a = int" > impl.ml $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml $ echo "type b = int [@@deriving deriver2_located_error]" >> impl.ml + + when the -embed-errors flag is not passed $ ./deriver.exe impl.ml File "impl.ml", line 2, characters 0-47: Error: A raised located error [1] + when the -embed-errors flag is passed + $ ./deriver.exe -embed-errors impl.ml + [%%ocaml.error "A raised located error"] + type a = int + type b = int[@@deriving deriver_located_error] + type b = int[@@deriving deriver2_located_error] + In the case of whole file transformations: $ echo "let x = 1+1. " > impl.ml @@ -77,6 +96,14 @@ and the whole AST is prepended with an error extension node. $ echo "let x = 1+1. " > impl.ml $ echo "let _ = [%gen_raise_located_error]" >> impl.ml $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml + +when the -embed-errors flag is not passed + $ ./extender.exe impl.ml + File "impl.ml", line 2, characters 8-34: + Error: A raised located error + [1] + + when the -embed-errors flag is passed $ ./extender.exe -embed-errors impl.ml [%%ocaml.error "A raised located error"] let x = 1 + 1. @@ -89,6 +116,13 @@ and the whole AST is prepended with an error extension node. $ echo "type a = int" > impl.ml $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml $ echo "type c = int [@@deriving deriver2_located_error]" >> impl.ml + + when the -embed-errors flag is not passed + $ ./deriver.exe impl.ml + File "impl.ml", line 2, characters 0-47: + Error: A raised located error + [1] + when the -embed-errors flag is passed $ ./deriver.exe -embed-errors impl.ml [%%ocaml.error "A raised located error"] type a = int From 1a97108ab3fe22a4274a69c59782c679e762368a Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Mon, 7 Aug 2023 10:58:58 +0100 Subject: [PATCH 06/20] proress: Allowing multiple errors to be reported in one pass of the context_free transformation. Signed-off-by: Burnleydev1 --- src/context_free.ml | 78 ++++++++++++---------- src/context_free.mli | 1 + src/driver.ml | 21 +++--- test/driver/exception_handling/deriver.ml | 21 ++++++ test/driver/exception_handling/extender.ml | 10 +-- test/driver/exception_handling/run.t | 27 +++++--- 6 files changed, 96 insertions(+), 62 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index 549f9ca42..1d0e61db7 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -404,15 +404,19 @@ module Expect_mismatch_handler = struct end class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) - ?(generated_code_hook = Generated_code_hook.nop) rules = + ?(generated_code_hook = Generated_code_hook.nop) rules ~embed_errors = let hook = generated_code_hook in let special_functions = - Rule.filter Special_function rules |> table_of_special_functions + try Rule.filter Special_function rules |> table_of_special_functions + with exn -> raise exn in let constants = - Rule.filter Constant rules - |> List.map ~f:(fun (c : Rule.Constant.t) -> ((c.suffix, c.kind), c.expand)) + (try + Rule.filter Constant rules + |> List.map ~f:(fun (c : Rule.Constant.t) -> + ((c.suffix, c.kind), c.expand)) + with exn -> raise exn) |> Hashtbl.of_alist_exn in let extensions = Rule.filter Extension rules in @@ -476,11 +480,11 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) method! core_type base_ctxt x = map_node EC.core_type core_type super#core_type x.ptyp_loc base_ctxt x - ~embed_errors:false + ~embed_errors method! pattern base_ctxt x = map_node EC.pattern pattern super#pattern x.ppat_loc base_ctxt x - ~embed_errors:false + ~embed_errors method! expression base_ctxt e = let with_context = @@ -503,14 +507,16 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | Pexp_extension _ -> map_node EC.expression expression (fun _ e -> return e) - e.pexp_loc base_ctxt e ~embed_errors:false + e.pexp_loc base_ctxt e ~embed_errors | _ -> return e in expanded >>= fun e -> let expand_constant kind char text = match Hashtbl.find_opt constants (char, kind) with | None -> super#expression base_ctxt e - | Some expand -> self#expression base_ctxt (expand e.pexp_loc text) + | Some expand -> ( + try self#expression base_ctxt (expand e.pexp_loc text) + with exn -> (e, [ exn_to_error exn ])) in match e.pexp_desc with | Pexp_apply (({ pexp_desc = Pexp_ident id; _ } as func), args) -> ( @@ -569,23 +575,23 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) method! class_type base_ctxt x = map_node EC.class_type class_type super#class_type x.pcty_loc base_ctxt x - ~embed_errors:false + ~embed_errors method! class_type_field base_ctxt x = map_node EC.class_type_field class_type_field super#class_type_field - x.pctf_loc base_ctxt x ~embed_errors:false + x.pctf_loc base_ctxt x ~embed_errors method! class_expr base_ctxt x = map_node EC.class_expr class_expr super#class_expr x.pcl_loc base_ctxt x - ~embed_errors:false + ~embed_errors method! class_field base_ctxt x = map_node EC.class_field class_field super#class_field x.pcf_loc base_ctxt - x ~embed_errors:false + x ~embed_errors method! module_type base_ctxt x = map_node EC.module_type module_type super#module_type x.pmty_loc base_ctxt - x ~embed_errors:false + x ~embed_errors method! module_expr base_ctxt x = ((* Make sure code-path attribute is applied before expanding. *) @@ -601,32 +607,32 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) (Expansion_context.Base.enter_module ~loc txt base_ctxt, x)) >>= fun (base_ctxt, x) -> map_node EC.module_expr module_expr super#module_expr x.pmod_loc base_ctxt - x ~embed_errors:false + x ~embed_errors method! structure_item base_ctxt x = map_node EC.structure_item structure_item super#structure_item x.pstr_loc - base_ctxt x ~embed_errors:false + base_ctxt x ~embed_errors method! signature_item base_ctxt x = map_node EC.signature_item signature_item super#signature_item x.psig_loc - base_ctxt x ~embed_errors:false + base_ctxt x ~embed_errors method! class_structure base_ctxt { pcstr_self; pcstr_fields } = self#pattern base_ctxt pcstr_self >>= fun pcstr_self -> map_nodes EC.class_field class_field super#class_field (fun x -> x.pcf_loc) - base_ctxt pcstr_fields ~embed_errors:false + base_ctxt pcstr_fields ~embed_errors >>| fun pcstr_fields -> { pcstr_self; pcstr_fields } method! type_declaration base_ctxt x = map_node EC.Ppx_import ppx_import super#type_declaration x.ptype_loc - base_ctxt x ~embed_errors:false + base_ctxt x ~embed_errors method! class_signature base_ctxt { pcsig_self; pcsig_fields } = self#core_type base_ctxt pcsig_self >>= fun pcsig_self -> map_nodes EC.class_type_field class_type_field super#class_type_field (fun x -> x.pctf_loc) - base_ctxt pcsig_fields ~embed_errors:false + base_ctxt pcsig_fields ~embed_errors >>| fun pcsig_fields -> { pcsig_self; pcsig_fields } (* TODO: try to factorize #structure and #signature without meta-programming *) @@ -685,40 +691,39 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) 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 - ~embed_errors:false + ~expanded_items:exp_tds ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_group_inline attr_str_type_decls_expect rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt - ~embed_errors:false + ~embed_errors >>= 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 ~embed_errors:false + ~expanded_item:exp_mtd ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_inline attr_str_module_type_decls_expect ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt - ~embed_errors:false + ~embed_errors >>= 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 ~embed_errors:false + ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_inline attr_str_type_exts_expect ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors:false + ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors >>= 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 ~embed_errors:false + ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_inline attr_str_exceptions_expect ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors:false + ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors >>= fun expect_items -> with_extra_items expanded_item ~extra_items ~expect_items ~rest ~in_generated_code @@ -783,40 +788,39 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) 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 - ~embed_errors:false + ~expanded_items:exp_tds ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_group_inline attr_sig_type_decls_expect rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt - ~embed_errors:false + ~embed_errors >>= 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 ~embed_errors:false + ~expanded_item:exp_mtd ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_inline attr_sig_module_type_decls_expect ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt - ~embed_errors:false + ~embed_errors >>= 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 ~embed_errors:false + ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_inline attr_sig_type_exts_expect ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors:false + ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors >>= 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 ~embed_errors:false + ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors >>= fun extra_items -> handle_attr_inline attr_sig_exceptions_expect ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors:false + ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors >>= fun expect_items -> with_extra_items expanded_item ~extra_items ~expect_items ~rest ~in_generated_code diff --git a/src/context_free.mli b/src/context_free.mli index 1979ceb89..5d9726b11 100644 --- a/src/context_free.mli +++ b/src/context_free.mli @@ -150,6 +150,7 @@ class map_top_down : -> ?generated_code_hook: Generated_code_hook.t (* default: Generated_code_hook.nop *) -> Rule.t list + -> embed_errors:bool -> object inherit Ast_traverse.map_with_expansion_context_and_errors end diff --git a/src/driver.ml b/src/driver.ml index 3caaed2cc..148c317fe 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -218,12 +218,12 @@ module Transform = struct let last = get_loc (last x l) in Some { first with loc_end = last.loc_end } - let merge_into_generic_mappers t ~hook ~expect_mismatch_handler ~tool_name - ~input_name = + let merge_into_generic_mappers t ~embed_errors ~hook ~expect_mismatch_handler + ~tool_name ~input_name = let { rules; enclose_impl; enclose_intf; impl; intf; _ } = t in let map = new Context_free.map_top_down - rules ~generated_code_hook:hook ~expect_mismatch_handler + rules ~embed_errors ~generated_code_hook:hook ~expect_mismatch_handler in let gen_header_and_footer context whole_loc f = let header, footer = f whole_loc in @@ -455,7 +455,8 @@ let debug_dropped_attribute name ~old_dropped ~new_dropped = print_diff "disappeared" new_dropped old_dropped; print_diff "reappeared" old_dropped new_dropped -let get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name ~input_name = +let get_whole_ast_passes ~embed_errors ~hook ~expect_mismatch_handler ~tool_name + ~input_name = let cts = match !apply_list with | None -> List.rev !Transform.all @@ -484,7 +485,7 @@ let get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name ~input_name = if !no_merge then List.map transforms ~f: - (Transform.merge_into_generic_mappers ~hook ~tool_name + (Transform.merge_into_generic_mappers ~embed_errors ~hook ~tool_name ~expect_mismatch_handler ~input_name) else (let get_enclosers ~f = @@ -515,8 +516,8 @@ let get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name ~input_name = let footers = List.concat (List.rev footers) in (headers, footers)) in - Transform.builtin_of_context_free_rewriters ~rules ~hook - ~expect_mismatch_handler + Transform.builtin_of_context_free_rewriters ~rules ~embed_errors + ~hook ~expect_mismatch_handler ~enclose_impl:(merge_encloser impl_enclosers) ~enclose_intf:(merge_encloser intf_enclosers) ~tool_name ~input_name @@ -529,7 +530,8 @@ let get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name ~input_name = let apply_transforms ~tool_name ~file_path ~field ~lint_field ~dropped_so_far ~hook ~expect_mismatch_handler ~input_name ~embed_errors ast = let cts = - get_whole_ast_passes ~tool_name ~hook ~expect_mismatch_handler ~input_name + get_whole_ast_passes ~tool_name ~embed_errors ~hook ~expect_mismatch_handler + ~input_name in let finish (ast, _dropped, lint_errors, errors) = ( ast, @@ -617,10 +619,11 @@ let exn_to_extension exn ~(kind : Kind.t) = let print_passes () = let tool_name = "ppxlib_driver" in + let embed_errors = false in let hook = Context_free.Generated_code_hook.nop in let expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop in let cts = - get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name + get_whole_ast_passes ~embed_errors ~hook ~expect_mismatch_handler ~tool_name ~input_name:None in if !perform_checks then diff --git a/test/driver/exception_handling/deriver.ml b/test/driver/exception_handling/deriver.ml index ac2453b4c..e6fb6ccf3 100644 --- a/test/driver/exception_handling/deriver.ml +++ b/test/driver/exception_handling/deriver.ml @@ -11,18 +11,31 @@ let generate_impl_located_error ~ctxt (_rec_flag, _type_declarations) = let loc = Expansion_context.Deriver.derived_item_loc ctxt in Location.raise_errorf ~loc "A raised located error" +let generate_impl_located_error2 ~ctxt (_rec_flag, _type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + Location.raise_errorf ~loc "A second raised located error" + let generate_impl_raised_exception ~ctxt:_ (_rec_flag, _type_declarations) = failwith "A raised exception" +let generate_impl_raised_exception2 ~ctxt:_ (_rec_flag, _type_declarations) = + failwith "A Second raised exception" + let impl_generator_extension_node = Deriving.Generator.V2.make_noarg generate_impl_extension_node let impl_generator_located_error = Deriving.Generator.V2.make_noarg generate_impl_located_error +let impl_generator_located_error2 = + Deriving.Generator.V2.make_noarg generate_impl_located_error2 + let impl_generator_raised_exception = Deriving.Generator.V2.make_noarg generate_impl_raised_exception +let impl_generator_raised_exception2 = + Deriving.Generator.V2.make_noarg generate_impl_raised_exception2 + let my_deriver_extension_node = Deriving.add "deriver_extension_node" ~str_type_decl:impl_generator_extension_node @@ -31,8 +44,16 @@ let my_deriver_located_error = Deriving.add "deriver_located_error" ~str_type_decl:impl_generator_located_error +let my_deriver_located_error2 = + Deriving.add "deriver_located_error2" + ~str_type_decl:impl_generator_located_error2 + let my_deriver_raised_exception = Deriving.add "deriver_raised_exception" ~str_type_decl:impl_generator_raised_exception +let my_deriver_raised_exception2 = + Deriving.add "deriver_raised_exception2" + ~str_type_decl:impl_generator_raised_exception2 + let () = Driver.standalone () diff --git a/test/driver/exception_handling/extender.ml b/test/driver/exception_handling/extender.ml index e0537ccc2..dd2aed630 100644 --- a/test/driver/exception_handling/extender.ml +++ b/test/driver/exception_handling/extender.ml @@ -13,7 +13,7 @@ let expand_raise_located_error ~ctxt = let loc = Expansion_context.Extension.extension_point_loc ctxt in Location.raise_errorf ~loc "A raised located error" -let expand2_raise_located_error ~ctxt = +let expand_raise_located_error2 ~ctxt = let loc = Expansion_context.Extension.extension_point_loc ctxt in Location.raise_errorf ~loc "A second raised located error" @@ -32,15 +32,15 @@ let raise_located_error_extension = Ast_pattern.(pstr nil) expand_raise_located_error -let raise2_located_error_extension = - Extension.V3.declare "gen2_raise_located_error" Extension.Context.expression +let raise_located_error_extension2 = + Extension.V3.declare "gen_raise_located_error2" Extension.Context.expression Ast_pattern.(pstr nil) - expand2_raise_located_error + expand_raise_located_error2 let rule1 = Ppxlib.Context_free.Rule.extension extension_point_extension let rule2 = Ppxlib.Context_free.Rule.extension raise_exception_extension let rule3 = Ppxlib.Context_free.Rule.extension raise_located_error_extension -let rule4 = Ppxlib.Context_free.Rule.extension raise2_located_error_extension +let rule4 = Ppxlib.Context_free.Rule.extension raise_located_error_extension2 let () = Driver.register_transformation diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 3240c756d..29c4d003c 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -44,7 +44,7 @@ caught, so no AST is produced. $ echo "let x = 1+1. " > impl.ml $ echo "let _ = [%gen_raise_located_error]" >> impl.ml - $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml + $ echo "let _ = [%gen_raise_located_error2]" >> impl.ml $ export OCAML_ERROR_STYLE=short when the -embed-errors flag is not passed @@ -57,15 +57,16 @@ 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 _ = [%gen2_raise_located_error ] + let _ = [%gen_raise_located_error2 ] In the case of derivers $ echo "type a = int" > impl.ml $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml - $ echo "type b = int [@@deriving deriver2_located_error]" >> impl.ml + $ echo "type c = int [@@deriving deriver_located_error2]" >> impl.ml when the -embed-errors flag is not passed $ ./deriver.exe impl.ml @@ -76,9 +77,10 @@ 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] - type b = int[@@deriving deriver2_located_error] + type c = int[@@deriving deriver_located_error2] In the case of whole file transformations: @@ -95,7 +97,7 @@ and the whole AST is prepended with an error extension node. $ echo "let x = 1+1. " > impl.ml $ echo "let _ = [%gen_raise_located_error]" >> impl.ml - $ echo "let _ = [%gen2_raise_located_error]" >> impl.ml + $ echo "let _ = [%gen_raise_located_error2]" >> impl.ml when the -embed-errors flag is not passed $ ./extender.exe impl.ml @@ -106,28 +108,31 @@ 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 _ = [%gen2_raise_located_error ] + let _ = [%gen_raise_located_error2 ] In the case of derivers $ echo "let x = 1+1. " > impl.ml - $ echo "type a = int" > impl.ml + $ echo "type a = int" >> impl.ml $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml - $ echo "type c = int [@@deriving deriver2_located_error]" >> impl.ml + $ echo "type b = int [@@deriving deriver_located_error2]" >> impl.ml when the -embed-errors flag is not passed $ ./deriver.exe impl.ml - File "impl.ml", line 2, characters 0-47: + File "impl.ml", line 3, characters 0-47: Error: A raised located error [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] - type c = int[@@deriving deriver2_located_error] + type b = int[@@deriving deriver_located_error2] In the case of whole file transformations: @@ -152,7 +157,7 @@ when the -embed-errors flag is not passed $ echo "type a = int" > impl.ml $ echo "type b = int [@@deriving deriver_raised_exception]" >> impl.ml - $ echo "type c = int [@@deriving deriver2_located_error]" >> impl.ml + $ echo "type b = int [@@deriving deriver_raised_exception2]" >> impl.ml $ ./deriver.exe -embed-errors impl.ml Fatal error: exception Failure("A raised exception") [2] From 5ad150deb9e28e75b8c95f857d71053fc10af594 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Tue, 8 Aug 2023 10:47:44 +0100 Subject: [PATCH 07/20] remove unused changes. Signed-off-by: Burnleydev1 --- src/context_free.ml | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index 1d0e61db7..846487286 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -408,15 +408,11 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) let hook = generated_code_hook in let special_functions = - try Rule.filter Special_function rules |> table_of_special_functions - with exn -> raise exn + Rule.filter Special_function rules |> table_of_special_functions in let constants = - (try - Rule.filter Constant rules - |> List.map ~f:(fun (c : Rule.Constant.t) -> - ((c.suffix, c.kind), c.expand)) - with exn -> raise exn) + Rule.filter Constant rules + |> List.map ~f:(fun (c : Rule.Constant.t) -> ((c.suffix, c.kind), c.expand)) |> Hashtbl.of_alist_exn in let extensions = Rule.filter Extension rules in From ad2fece159310d6326392ce3cd9413684189740b Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Wed, 9 Aug 2023 12:38:24 +0100 Subject: [PATCH 08/20] In progress: constant_type and special_functions can report multiple errors Signed-off-by: Burnleydev1 --- src/context_free.ml | 14 +++++--- .../exception_handling/constant_type.ml | 9 +++++ test/driver/exception_handling/dune | 6 ++-- test/driver/exception_handling/run.t | 35 +++++++++++++++++++ .../exception_handling/special_functions.ml | 11 ++++++ 5 files changed, 69 insertions(+), 6 deletions(-) create mode 100644 test/driver/exception_handling/constant_type.ml create mode 100644 test/driver/exception_handling/special_functions.ml diff --git a/src/context_free.ml b/src/context_free.ml index 846487286..3295338cc 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -512,7 +512,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | None -> super#expression base_ctxt e | Some expand -> ( try self#expression base_ctxt (expand e.pexp_loc text) - with exn -> (e, [ exn_to_error exn ])) + with exn when embed_errors -> (e, [ exn_to_error exn ])) in match e.pexp_desc with | Pexp_apply (({ pexp_desc = Pexp_ident id; _ } as func), args) -> ( @@ -524,18 +524,24 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | None -> self#pexp_apply_without_traversing_function base_ctxt e func args - | Some e -> self#expression base_ctxt e)) + | Some e -> ( + try self#expression base_ctxt e + with exn when embed_errors -> (e, [ exn_to_error exn ])))) | Pexp_ident id -> ( match Hashtbl.find_opt special_functions id.txt with | None -> super#expression base_ctxt e | Some pattern -> ( match pattern e with | None -> super#expression base_ctxt e - | Some e -> self#expression base_ctxt e)) + | Some e -> ( + try self#expression base_ctxt e + with exn when embed_errors -> (e, [ exn_to_error exn ])))) | Pexp_constant (Pconst_integer (s, Some c)) -> expand_constant Integer c s | Pexp_constant (Pconst_float (s, Some c)) -> expand_constant Float c s - | _ -> super#expression base_ctxt e + | _ -> ( + try super#expression base_ctxt e + with exn when embed_errors -> (e, [ exn_to_error exn ])) (* Pre-conditions: - e.pexp_desc = Pexp_apply(func, args) diff --git a/test/driver/exception_handling/constant_type.ml b/test/driver/exception_handling/constant_type.ml new file mode 100644 index 000000000..28ed9277d --- /dev/null +++ b/test/driver/exception_handling/constant_type.ml @@ -0,0 +1,9 @@ +open Ppxlib + +let kind = Context_free.Rule.Constant_kind.Integer +let rewriter loc s = Location.raise_errorf ~loc "rewriter %s failed" s +let rule = Context_free.Rule.constant kind 'g' rewriter;; + +Driver.register_transformation ~rules:[ rule ] "constant" + +let () = Driver.standalone () diff --git a/test/driver/exception_handling/dune b/test/driver/exception_handling/dune index b4ee27597..f37c12864 100644 --- a/test/driver/exception_handling/dune +++ b/test/driver/exception_handling/dune @@ -1,8 +1,10 @@ (executables (names whole_file_exception whole_file_extension_point - whole_file_located_error extender deriver whole_file_multiple_errors) + whole_file_located_error extender deriver whole_file_multiple_errors + constant_type special_functions) (libraries ppxlib)) (cram (deps extender.exe whole_file_exception.exe whole_file_located_error.exe - deriver.exe whole_file_extension_point.exe whole_file_multiple_errors.exe)) + deriver.exe whole_file_extension_point.exe whole_file_multiple_errors.exe + constant_type.exe special_functions.exe)) diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 29c4d003c..87e48400a 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -162,8 +162,43 @@ when the -embed-errors flag is not passed Fatal error: exception Failure("A raised exception") [2] + In the case of Constant types + + $ echo "let x = 2g + 3g" > impl.ml + $ echo "let x = 2g + 3g" >> impl.ml + + When embed-errors is not passed + $ ./constant_type.exe impl.ml + File "impl.ml", line 1, characters 8-10: + Error: rewriter 2 failed + [1] + + When embed-errors is not passed + $ ./constant_type.exe -embed-errors impl.ml + [%%ocaml.error "rewriter 2 failed"] + [%%ocaml.error "rewriter 3 failed"] + [%%ocaml.error "rewriter 2 failed"] + [%%ocaml.error "rewriter 3 failed"] + let x = 2g + 3g + let x = 2g + 3g + + In the case of Special functions + + $ echo "let _ = (f_macro arg1 arg2, f_macro)" > impl.ml + $ echo "let _ = (f_macro arg1 arg2, f_macro)" >> impl.ml + When embed-errors is not passed + $ ./special_functions.exe impl.ml + let _ = ((f_macro arg1 arg2), f_macro) + let _ = ((f_macro arg1 arg2), f_macro) + + When embed-errors is not passed + $ ./special_functions.exe -embed-errors impl.ml + let _ = ((f_macro arg1 arg2), f_macro) + let _ = ((f_macro arg1 arg2), f_macro) + In the case of whole file transformations: + $ echo "let _ = [%gen_raise_exc] + [%gen_raise_exc]" > impl.ml $ ./whole_file_exception.exe impl.ml Fatal error: exception Failure("An exception in a whole file transform") [2] diff --git a/test/driver/exception_handling/special_functions.ml b/test/driver/exception_handling/special_functions.ml new file mode 100644 index 000000000..a8bd81176 --- /dev/null +++ b/test/driver/exception_handling/special_functions.ml @@ -0,0 +1,11 @@ +open Ppxlib + +let expand e = + let loc = e.pexp_loc in + Location.raise_errorf ~loc "This is an example error" + +let rule = Context_free.Rule.special_function "n_args" expand + +let () = + Driver.register_transformation ~rules:[ rule ] "special_function_demo"; + Driver.standalone () From cabaf58f221db1c321c866bb485f08481b28d35a Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Thu, 10 Aug 2023 10:13:07 +0100 Subject: [PATCH 09/20] In progress: implemented requested changes. Signed-off-by: Burnleydev1 --- CHANGES.md | 3 ++- src/context_free.ml | 12 +++--------- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 12859645d..f4ae05555 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,7 +1,7 @@ unreleased ------------------- -- Allowing multiple errors to be reported in one pass of the context_free transformation.(#453, @burnleydev1) +- raising an exception does no longer cancel the whole context free phase(#453, @burnleydev1) - Sort embedded errors that are appended to the AST by location so the compiler reports the one closer to the beginning of the file first. (#463, @NathanReb) @@ -450,3 +450,4 @@ unreleased ----- Initial release. + diff --git a/src/context_free.ml b/src/context_free.ml index 3295338cc..a6167b46a 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -524,24 +524,18 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | None -> self#pexp_apply_without_traversing_function base_ctxt e func args - | Some e -> ( - try self#expression base_ctxt e - with exn when embed_errors -> (e, [ exn_to_error exn ])))) + | Some e -> self#expression base_ctxt e)) | Pexp_ident id -> ( match Hashtbl.find_opt special_functions id.txt with | None -> super#expression base_ctxt e | Some pattern -> ( match pattern e with | None -> super#expression base_ctxt e - | Some e -> ( - try self#expression base_ctxt e - with exn when embed_errors -> (e, [ exn_to_error exn ])))) + | Some e -> self#expression base_ctxt e)) | Pexp_constant (Pconst_integer (s, Some c)) -> expand_constant Integer c s | Pexp_constant (Pconst_float (s, Some c)) -> expand_constant Float c s - | _ -> ( - try super#expression base_ctxt e - with exn when embed_errors -> (e, [ exn_to_error exn ])) + | _ -> super#expression base_ctxt e (* Pre-conditions: - e.pexp_desc = Pexp_apply(func, args) From 32c0dd6c06a299f1a6b7f7be6e9d9b5f99728d03 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Thu, 10 Aug 2023 10:19:21 +0100 Subject: [PATCH 10/20] In progress: implemented requested changes. Signed-off-by: Burnleydev1 --- test/driver/exception_handling/constant_type.ml | 2 +- test/driver/exception_handling/run.t | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/test/driver/exception_handling/constant_type.ml b/test/driver/exception_handling/constant_type.ml index 28ed9277d..4ddc2d61a 100644 --- a/test/driver/exception_handling/constant_type.ml +++ b/test/driver/exception_handling/constant_type.ml @@ -1,7 +1,7 @@ open Ppxlib let kind = Context_free.Rule.Constant_kind.Integer -let rewriter loc s = Location.raise_errorf ~loc "rewriter %s failed" s +let rewriter loc s = Location.raise_errorf ~loc "A raised located error." s let rule = Context_free.Rule.constant kind 'g' rewriter;; Driver.register_transformation ~rules:[ rule ] "constant" diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 87e48400a..fef1832e0 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -170,15 +170,15 @@ when the -embed-errors flag is not passed When embed-errors is not passed $ ./constant_type.exe impl.ml File "impl.ml", line 1, characters 8-10: - Error: rewriter 2 failed + Error: A raised located error. [1] When embed-errors is not passed $ ./constant_type.exe -embed-errors impl.ml - [%%ocaml.error "rewriter 2 failed"] - [%%ocaml.error "rewriter 3 failed"] - [%%ocaml.error "rewriter 2 failed"] - [%%ocaml.error "rewriter 3 failed"] + [%%ocaml.error "A raised located error."] + [%%ocaml.error "A raised located error."] + [%%ocaml.error "A raised located error."] + [%%ocaml.error "A raised located error."] let x = 2g + 3g let x = 2g + 3g From a7ba2305c58dcbda05bae6e33c3cd7c71e7861ca Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Fri, 11 Aug 2023 08:55:41 +0100 Subject: [PATCH 11/20] In progress: implemented requested changes. Signed-off-by: Burnleydev1 --- src/context_free.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index a6167b46a..3bdb28763 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -510,9 +510,8 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) let expand_constant kind char text = match Hashtbl.find_opt constants (char, kind) with | None -> super#expression base_ctxt e - | Some expand -> ( - try self#expression base_ctxt (expand e.pexp_loc text) - with exn when embed_errors -> (e, [ exn_to_error exn ])) + | Some expand -> self#expression base_ctxt (expand e.pexp_loc text) + (* with exn when embed_errors -> (e, [ exn_to_error exn ])) *) in match e.pexp_desc with | Pexp_apply (({ pexp_desc = Pexp_ident id; _ } as func), args) -> ( @@ -532,9 +531,12 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) match pattern e with | None -> super#expression base_ctxt e | Some e -> self#expression base_ctxt e)) - | Pexp_constant (Pconst_integer (s, Some c)) -> - expand_constant Integer c s - | Pexp_constant (Pconst_float (s, Some c)) -> expand_constant Float c s + | Pexp_constant (Pconst_integer (s, Some c)) -> ( + try expand_constant Integer c s + with exn when embed_errors -> (e, [ exn_to_error exn ])) + | Pexp_constant (Pconst_float (s, Some c)) -> ( + try expand_constant Float c s + with exn when embed_errors -> (e, [ exn_to_error exn ])) | _ -> super#expression base_ctxt e (* Pre-conditions: From 1f06a4db3c99f975a8636281b851728a7ffbbf46 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Fri, 11 Aug 2023 09:03:10 +0100 Subject: [PATCH 12/20] minor changes Signed-off-by: Burnleydev1 --- src/context_free.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/context_free.ml b/src/context_free.ml index 3bdb28763..8a7e831ea 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -511,7 +511,6 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) match Hashtbl.find_opt constants (char, kind) with | None -> super#expression base_ctxt e | Some expand -> self#expression base_ctxt (expand e.pexp_loc text) - (* with exn when embed_errors -> (e, [ exn_to_error exn ])) *) in match e.pexp_desc with | Pexp_apply (({ pexp_desc = Pexp_ident id; _ } as func), args) -> ( From 8609b4bd6e6dea828644c1ae7e090a452e37346e Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Mon, 14 Aug 2023 23:37:27 +0100 Subject: [PATCH 13/20] create fix value for embed_error in map_node and attrs. Signed-off-by: Burnleydev1 --- src/context_free.ml | 58 +++++++++---------- .../exception_handling/constant_type.ml | 6 +- test/driver/exception_handling/run.t | 14 +++-- 3 files changed, 40 insertions(+), 38 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index 8a7e831ea..ab58b9525 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -465,8 +465,10 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in - let map_node = map_node ~hook in - let map_nodes = map_nodes ~hook in + let map_node = map_node ~hook ~embed_errors in + let map_nodes = map_nodes ~hook ~embed_errors in + let handle_attr_group_inline = handle_attr_group_inline ~embed_errors in + let handle_attr_inline = handle_attr_inline ~embed_errors in object (self) inherit Ast_traverse.map_with_expansion_context_and_errors as super @@ -476,11 +478,9 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) method! core_type base_ctxt x = map_node EC.core_type core_type super#core_type x.ptyp_loc base_ctxt x - ~embed_errors method! pattern base_ctxt x = map_node EC.pattern pattern super#pattern x.ppat_loc base_ctxt x - ~embed_errors method! expression base_ctxt e = let with_context = @@ -503,7 +503,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | Pexp_extension _ -> map_node EC.expression expression (fun _ e -> return e) - e.pexp_loc base_ctxt e ~embed_errors + e.pexp_loc base_ctxt e | _ -> return e in expanded >>= fun e -> @@ -572,23 +572,21 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) method! class_type base_ctxt x = map_node EC.class_type class_type super#class_type x.pcty_loc base_ctxt x - ~embed_errors method! class_type_field base_ctxt x = map_node EC.class_type_field class_type_field super#class_type_field - x.pctf_loc base_ctxt x ~embed_errors + x.pctf_loc base_ctxt x method! class_expr base_ctxt x = map_node EC.class_expr class_expr super#class_expr x.pcl_loc base_ctxt x - ~embed_errors method! class_field base_ctxt x = map_node EC.class_field class_field super#class_field x.pcf_loc base_ctxt - x ~embed_errors + x method! module_type base_ctxt x = map_node EC.module_type module_type super#module_type x.pmty_loc base_ctxt - x ~embed_errors + x method! module_expr base_ctxt x = ((* Make sure code-path attribute is applied before expanding. *) @@ -604,32 +602,32 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) (Expansion_context.Base.enter_module ~loc txt base_ctxt, x)) >>= fun (base_ctxt, x) -> map_node EC.module_expr module_expr super#module_expr x.pmod_loc base_ctxt - x ~embed_errors + x method! structure_item base_ctxt x = map_node EC.structure_item structure_item super#structure_item x.pstr_loc - base_ctxt x ~embed_errors + base_ctxt x method! signature_item base_ctxt x = map_node EC.signature_item signature_item super#signature_item x.psig_loc - base_ctxt x ~embed_errors + base_ctxt x method! class_structure base_ctxt { pcstr_self; pcstr_fields } = self#pattern base_ctxt pcstr_self >>= fun pcstr_self -> map_nodes EC.class_field class_field super#class_field (fun x -> x.pcf_loc) - base_ctxt pcstr_fields ~embed_errors + base_ctxt pcstr_fields >>| fun pcstr_fields -> { pcstr_self; pcstr_fields } method! type_declaration base_ctxt x = map_node EC.Ppx_import ppx_import super#type_declaration x.ptype_loc - base_ctxt x ~embed_errors + base_ctxt x method! class_signature base_ctxt { pcsig_self; pcsig_fields } = self#core_type base_ctxt pcsig_self >>= fun pcsig_self -> map_nodes EC.class_type_field class_type_field super#class_type_field (fun x -> x.pctf_loc) - base_ctxt pcsig_fields ~embed_errors + base_ctxt pcsig_fields >>| fun pcsig_fields -> { pcsig_self; pcsig_fields } (* TODO: try to factorize #structure and #signature without meta-programming *) @@ -688,39 +686,37 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) 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 ~embed_errors + ~expanded_items:exp_tds ~loc ~base_ctxt >>= fun extra_items -> handle_attr_group_inline attr_str_type_decls_expect rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt - ~embed_errors >>= 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 ~embed_errors + ~expanded_item:exp_mtd ~loc ~base_ctxt >>= fun extra_items -> handle_attr_inline attr_str_module_type_decls_expect ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt - ~embed_errors >>= 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 ~embed_errors + ~expanded_item:exp_te ~loc ~base_ctxt >>= fun extra_items -> handle_attr_inline attr_str_type_exts_expect ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors + ~expanded_item:exp_te ~loc ~base_ctxt >>= 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 ~embed_errors + ~expanded_item:exp_ec ~loc ~base_ctxt >>= fun extra_items -> handle_attr_inline attr_str_exceptions_expect ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors + ~expanded_item:exp_ec ~loc ~base_ctxt >>= fun expect_items -> with_extra_items expanded_item ~extra_items ~expect_items ~rest ~in_generated_code @@ -785,39 +781,37 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) 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 ~embed_errors + ~expanded_items:exp_tds ~loc ~base_ctxt >>= fun extra_items -> handle_attr_group_inline attr_sig_type_decls_expect rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt - ~embed_errors >>= 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 ~embed_errors + ~expanded_item:exp_mtd ~loc ~base_ctxt >>= fun extra_items -> handle_attr_inline attr_sig_module_type_decls_expect ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt - ~embed_errors >>= 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 ~embed_errors + ~expanded_item:exp_te ~loc ~base_ctxt >>= fun extra_items -> handle_attr_inline attr_sig_type_exts_expect ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt ~embed_errors + ~expanded_item:exp_te ~loc ~base_ctxt >>= 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 ~embed_errors + ~expanded_item:exp_ec ~loc ~base_ctxt >>= fun extra_items -> handle_attr_inline attr_sig_exceptions_expect ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt ~embed_errors + ~expanded_item:exp_ec ~loc ~base_ctxt >>= fun expect_items -> with_extra_items expanded_item ~extra_items ~expect_items ~rest ~in_generated_code diff --git a/test/driver/exception_handling/constant_type.ml b/test/driver/exception_handling/constant_type.ml index 4ddc2d61a..6b8efbf6f 100644 --- a/test/driver/exception_handling/constant_type.ml +++ b/test/driver/exception_handling/constant_type.ml @@ -1,7 +1,11 @@ open Ppxlib let kind = Context_free.Rule.Constant_kind.Integer -let rewriter loc s = Location.raise_errorf ~loc "A raised located error." s + +let rewriter loc s = + Location.raise_errorf ~loc + "A raised located error in the constant rewriting transformation." s + let rule = Context_free.Rule.constant kind 'g' rewriter;; Driver.register_transformation ~rules:[ rule ] "constant" diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index fef1832e0..98b54a957 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -170,15 +170,19 @@ when the -embed-errors flag is not passed When embed-errors is not passed $ ./constant_type.exe impl.ml File "impl.ml", line 1, characters 8-10: - Error: A raised located error. + Error: A raised located error in the constant rewriting transformation. [1] When embed-errors is not passed $ ./constant_type.exe -embed-errors impl.ml - [%%ocaml.error "A raised located error."] - [%%ocaml.error "A raised located error."] - [%%ocaml.error "A raised located error."] - [%%ocaml.error "A raised located error."] + [%%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 From becbc486a41286b8a2a1c0208cf11ecbf2b5b246 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Fri, 18 Aug 2023 10:51:05 +0100 Subject: [PATCH 14/20] Added some test for special functions Signed-off-by: Burnleydev1 --- test/driver/exception_handling/run.t | 13 ++++++------ .../exception_handling/special_functions.ml | 20 ++++++++++++++----- 2 files changed, 22 insertions(+), 11 deletions(-) diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 98b54a957..bcf8441b8 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -188,17 +188,18 @@ when the -embed-errors flag is not passed In the case of Special functions - $ echo "let _ = (f_macro arg1 arg2, f_macro)" > impl.ml - $ echo "let _ = (f_macro arg1 arg2, f_macro)" >> impl.ml + $ echo "n_args " > impl.ml + $ echo "n_args2 " >> impl.ml When embed-errors is not passed $ ./special_functions.exe impl.ml - let _ = ((f_macro arg1 arg2), f_macro) - let _ = ((f_macro arg1 arg2), f_macro) + File "_none_", line 1: + Error: error special function + [1] When embed-errors is not passed $ ./special_functions.exe -embed-errors impl.ml - let _ = ((f_macro arg1 arg2), f_macro) - let _ = ((f_macro arg1 arg2), f_macro) + [%%ocaml.error "error special function"] + ;;n_args n_args2 In the case of whole file transformations: diff --git a/test/driver/exception_handling/special_functions.ml b/test/driver/exception_handling/special_functions.ml index a8bd81176..bc45a9698 100644 --- a/test/driver/exception_handling/special_functions.ml +++ b/test/driver/exception_handling/special_functions.ml @@ -1,11 +1,21 @@ open Ppxlib let expand e = - let loc = e.pexp_loc in - Location.raise_errorf ~loc "This is an example error" + let return n = Some (Ast_builder.Default.eint ~loc:e.pexp_loc n) in + match e.pexp_desc with + | Pexp_apply (_, _arg_list) -> Location.raise_errorf "error special function" + | _ -> return 0 + +let expand2 e = + let return n = Some (Ast_builder.Default.eint ~loc:e.pexp_loc n) in + match e.pexp_desc with + | Pexp_apply (_, _arg_list2) -> + Location.raise_errorf "error special function 2" + | _ -> return 0 let rule = Context_free.Rule.special_function "n_args" expand +let rule2 = Context_free.Rule.special_function "n_args2" expand2;; + +Driver.register_transformation ~rules:[ rule; rule2 ] "special_function_demo" -let () = - Driver.register_transformation ~rules:[ rule ] "special_function_demo"; - Driver.standalone () +let () = Driver.standalone () From b1855e963fc21e87903225118f911b26ba4c6fb0 Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Tue, 22 Aug 2023 11:05:29 +0100 Subject: [PATCH 15/20] improvements on special functions Signed-off-by: Burnleydev1 --- src/context_free.ml | 20 +++++++++++++++---- test/driver/exception_handling/run.t | 7 ++++--- .../exception_handling/special_functions.ml | 12 ++--------- 3 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index ab58b9525..efced3382 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -518,18 +518,30 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | None -> self#pexp_apply_without_traversing_function base_ctxt e func args | Some pattern -> ( - match pattern e with + let pat_expr = + try (pattern e, []) + with exn when embed_errors -> (None, [ exn_to_error exn ]) + in + pat_expr >>= fun expr -> + match expr with | None -> self#pexp_apply_without_traversing_function base_ctxt e func args - | Some e -> self#expression base_ctxt e)) + | Some e -> self#expression base_ctxt e + (* with exn when embed_errors -> (e, [ exn_to_error exn ]) *))) | Pexp_ident id -> ( match Hashtbl.find_opt special_functions id.txt with | None -> super#expression base_ctxt e | Some pattern -> ( - match pattern e with + let pat_exp = + try (pattern e, []) + with exn when embed_errors -> (None, [ exn_to_error exn ]) + in + pat_exp >>= fun expr -> + match expr with | None -> super#expression base_ctxt e - | Some e -> self#expression base_ctxt e)) + | Some e -> self#expression base_ctxt e + (* with exn when embed_errors -> (e, [ exn_to_error exn ]) *))) | Pexp_constant (Pconst_integer (s, Some c)) -> ( try expand_constant Integer c s with exn when embed_errors -> (e, [ exn_to_error exn ])) diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index bcf8441b8..795954f63 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -192,13 +192,14 @@ when the -embed-errors flag is not passed $ echo "n_args2 " >> impl.ml When embed-errors is not passed $ ./special_functions.exe impl.ml - File "_none_", line 1: - Error: error special function + File "impl.ml", lines 1-2, characters 0-7: + Error: error special function [1] When embed-errors is not passed $ ./special_functions.exe -embed-errors impl.ml - [%%ocaml.error "error special function"] + [%%ocaml.error "error special function "] + [%%ocaml.error "second error special function"] ;;n_args n_args2 In the case of whole file transformations: diff --git a/test/driver/exception_handling/special_functions.ml b/test/driver/exception_handling/special_functions.ml index bc45a9698..09b24bb58 100644 --- a/test/driver/exception_handling/special_functions.ml +++ b/test/driver/exception_handling/special_functions.ml @@ -1,17 +1,9 @@ open Ppxlib -let expand e = - let return n = Some (Ast_builder.Default.eint ~loc:e.pexp_loc n) in - match e.pexp_desc with - | Pexp_apply (_, _arg_list) -> Location.raise_errorf "error special function" - | _ -> return 0 +let expand e = Location.raise_errorf ~loc:e.pexp_loc "error special function " let expand2 e = - let return n = Some (Ast_builder.Default.eint ~loc:e.pexp_loc n) in - match e.pexp_desc with - | Pexp_apply (_, _arg_list2) -> - Location.raise_errorf "error special function 2" - | _ -> return 0 + Location.raise_errorf ~loc:e.pexp_loc "second error special function" let rule = Context_free.Rule.special_function "n_args" expand let rule2 = Context_free.Rule.special_function "n_args2" expand2;; From 8561870452270ee015f49daf7b728f0c3aa97feb Mon Sep 17 00:00:00 2001 From: Burnleydev1 Date: Tue, 22 Aug 2023 12:04:41 +0100 Subject: [PATCH 16/20] applying requested changes. Signed-off-by: Burnleydev1 --- src/context_free.ml | 18 ++++++++---------- test/driver/exception_handling/run.t | 4 ++-- .../exception_handling/special_functions.ml | 2 +- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index efced3382..40a661231 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -518,30 +518,28 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | None -> self#pexp_apply_without_traversing_function base_ctxt e func args | Some pattern -> ( - let pat_expr = - try (pattern e, []) + let generated_code = + try return (pattern e) with exn when embed_errors -> (None, [ exn_to_error exn ]) in - pat_expr >>= fun expr -> + generated_code >>= fun expr -> match expr with | None -> self#pexp_apply_without_traversing_function base_ctxt e func args - | Some e -> self#expression base_ctxt e - (* with exn when embed_errors -> (e, [ exn_to_error exn ]) *))) + | Some e -> self#expression base_ctxt e)) | Pexp_ident id -> ( match Hashtbl.find_opt special_functions id.txt with | None -> super#expression base_ctxt e | Some pattern -> ( - let pat_exp = - try (pattern e, []) + let generated_code = + try return (pattern e) with exn when embed_errors -> (None, [ exn_to_error exn ]) in - pat_exp >>= fun expr -> + generated_code >>= fun expr -> match expr with | None -> super#expression base_ctxt e - | Some e -> self#expression base_ctxt e - (* with exn when embed_errors -> (e, [ exn_to_error exn ]) *))) + | 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_error exn ])) diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 795954f63..9f3430e74 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -193,12 +193,12 @@ when the -embed-errors flag is not passed When embed-errors is not passed $ ./special_functions.exe impl.ml File "impl.ml", lines 1-2, characters 0-7: - Error: error special function + Error: error special function [1] When embed-errors is not passed $ ./special_functions.exe -embed-errors impl.ml - [%%ocaml.error "error special function "] + [%%ocaml.error "error special function"] [%%ocaml.error "second error special function"] ;;n_args n_args2 diff --git a/test/driver/exception_handling/special_functions.ml b/test/driver/exception_handling/special_functions.ml index 09b24bb58..3d3bbc365 100644 --- a/test/driver/exception_handling/special_functions.ml +++ b/test/driver/exception_handling/special_functions.ml @@ -1,6 +1,6 @@ open Ppxlib -let expand e = Location.raise_errorf ~loc:e.pexp_loc "error special function " +let expand e = Location.raise_errorf ~loc:e.pexp_loc "error special function" let expand2 e = Location.raise_errorf ~loc:e.pexp_loc "second error special function" From 30c9913b72204c1c9ff9baf713ef731b55d7d22f Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 11 Jan 2024 14:39:14 +0100 Subject: [PATCH 17/20] Fix failing test Signed-off-by: Nathan Rebours --- test/driver/exception_handling/run.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 9f3430e74..99123806b 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -217,7 +217,7 @@ when the -embed-errors flag is not passed When the `-embed-error` flag is not set, exceptions stop the rewriting process. Therefore, only the first exception is reported to the user $ ./whole_file_multiple_errors.exe impl.ml - File "impl.ml", line 1, characters 0-12: + File "impl.ml", line 1, characters 0-43: Error: Raising a located exception during the first instrumentation phase [1] From 5e09949a92773c575add2e6824d8f4cc6d7f2292 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 11 Jan 2024 14:43:08 +0100 Subject: [PATCH 18/20] Remove unwanted empty line at the end of CHANGES.md Signed-off-by: Nathan Rebours --- CHANGES.md | 1 - 1 file changed, 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index f4ae05555..0ef1f78d3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -450,4 +450,3 @@ unreleased ----- Initial release. - From d73ae801c67af1fad1b29d6e58954f50289061e0 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 11 Jan 2024 15:26:28 +0100 Subject: [PATCH 19/20] Factor out exn_to_error Signed-off-by: Nathan Rebours --- src/common.ml | 3 +++ src/common.mli | 3 +++ src/context_free.ml | 21 +++++++++------------ src/driver.ml | 15 +++------------ 4 files changed, 18 insertions(+), 24 deletions(-) diff --git a/src/common.ml b/src/common.ml index 12f5e5274..d0e9dbd0e 100644 --- a/src/common.ml +++ b/src/common.ml @@ -254,6 +254,9 @@ let mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant = function [ Pwith_typesubst (Located.lident ~loc "t", for_subst) ])) | _ -> None +let exn_to_loc_error exn = + match Location.Error.of_exn exn with Some error -> error | None -> raise exn + module With_errors = struct type 'a t = 'a * Location.Error.t list diff --git a/src/common.mli b/src/common.mli index 765adf5ad..d09d0f58e 100644 --- a/src/common.mli +++ b/src/common.mli @@ -88,6 +88,9 @@ val mk_named_sig : It will take care of giving fresh names to unnamed type parameters. *) +val exn_to_loc_error : exn -> Location.Error.t +(** Convert [exn] to a located error if possible or reraise it otherwise *) + module With_errors : sig type 'a t = 'a * Location.Error.t list diff --git a/src/context_free.ml b/src/context_free.ml index 40a661231..b99b48e64 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -197,9 +197,6 @@ module Generated_code_hook = struct | _ -> t.f context { loc with loc_start = loc.loc_end } x end -let exn_to_error exn = - match Location.Error.of_exn exn with None -> raise exn | Some error -> error - 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 () @@ -210,7 +207,7 @@ 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_error exn ])) + with exn when embed_errors -> (None, [ exn_to_loc_error exn ])) >>= fun converted -> match converted with | None -> super_call base_ctxt x @@ -230,7 +227,7 @@ 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_error exn ])) + with exn when embed_errors -> (None, [ exn_to_loc_error exn ])) >>= fun converted -> match converted with | None -> super_call base_ctxt x @@ -264,7 +261,7 @@ 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_error exn ])) + with exn when embed_errors -> (None, [ exn_to_loc_error exn ])) >>= function | None -> super_call base_ctxt x >>= fun x -> @@ -371,7 +368,7 @@ 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_error exn ]))) + with exn when embed_errors -> (acc, [ exn_to_loc_error exn ]))) let handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt ~embed_errors = @@ -393,7 +390,7 @@ 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_error exn ]))) + with exn when embed_errors -> (acc, [ exn_to_loc_error exn ]))) module Expect_mismatch_handler = struct type t = { @@ -520,7 +517,7 @@ 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_error exn ]) + with exn when embed_errors -> (None, [ exn_to_loc_error exn ]) in generated_code >>= fun expr -> match expr with @@ -534,7 +531,7 @@ 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_error exn ]) + with exn when embed_errors -> (None, [ exn_to_loc_error exn ]) in generated_code >>= fun expr -> match expr with @@ -542,10 +539,10 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | 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_error exn ])) + with exn when embed_errors -> (e, [ exn_to_loc_error exn ])) | Pexp_constant (Pconst_float (s, Some c)) -> ( try expand_constant Float c s - with exn when embed_errors -> (e, [ exn_to_error exn ])) + with exn when embed_errors -> (e, [ exn_to_loc_error exn ])) | _ -> super#expression base_ctxt e (* Pre-conditions: diff --git a/src/driver.ml b/src/driver.ml index 148c317fe..c95eea78a 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -539,13 +539,6 @@ let apply_transforms ~tool_name ~file_path ~field ~lint_field ~dropped_so_far Common.attribute_of_warning loc s), errors ) in - - let exn_to_error exn = - match Location.Error.of_exn exn with - | None -> raise exn - | Some error -> error - in - let acc = List.fold_left cts ~init:(ast, [], [], []) ~f:(fun (ast, dropped, (lint_errors : _ list), errors) (ct : Transform.t) @@ -565,7 +558,7 @@ let apply_transforms ~tool_name ~file_path ~field ~lint_field ~dropped_so_far | Some f -> ( try (lint_errors @ f ctxt ast, errors) with exn when embed_errors -> - (lint_errors, exn_to_error exn :: errors)) + (lint_errors, exn_to_loc_error exn :: errors)) in match field ct with | None -> (ast, dropped, lint_errors, errors) @@ -573,7 +566,7 @@ let apply_transforms ~tool_name ~file_path ~field ~lint_field ~dropped_so_far let (ast, more_errors), errors = try (f ctxt ast, errors) with exn when embed_errors -> - ((ast, []), exn_to_error exn :: errors) + ((ast, []), exn_to_loc_error exn :: errors) in let dropped = if !debug_attribute_drop then ( @@ -609,9 +602,7 @@ let error_to_extension error ~(kind : Kind.t) = | Impl -> Intf_or_impl.Impl [ error_to_str_extension error ] let exn_to_extension exn ~(kind : Kind.t) = - match Location.Error.of_exn exn with - | None -> raise exn - | Some error -> error_to_extension error ~kind + exn_to_loc_error exn |> error_to_extension ~kind (* +-----------------------------------------------------------------+ | Actual rewriting of structure/signatures | From c3f3c7ae4139097a2af5d65c271b393e2e08a9a4 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 30 Jan 2024 12:52:12 +0100 Subject: [PATCH 20/20] Polish context-free exception test Signed-off-by: Nathan Rebours --- test/driver/exception_handling/run.t | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t index 99123806b..27d36f208 100644 --- a/test/driver/exception_handling/run.t +++ b/test/driver/exception_handling/run.t @@ -188,11 +188,11 @@ when the -embed-errors flag is not passed In the case of Special functions - $ echo "n_args " > impl.ml - $ echo "n_args2 " >> impl.ml + $ echo "let x1 = n_args" > impl.ml + $ echo "let x2 = n_args2" >> impl.ml When embed-errors is not passed $ ./special_functions.exe impl.ml - File "impl.ml", lines 1-2, characters 0-7: + File "impl.ml", line 1, characters 9-15: Error: error special function [1] @@ -200,7 +200,8 @@ when the -embed-errors flag is not passed $ ./special_functions.exe -embed-errors impl.ml [%%ocaml.error "error special function"] [%%ocaml.error "second error special function"] - ;;n_args n_args2 + let x1 = n_args + let x2 = n_args2 In the case of whole file transformations: