From aab242e3d2c2ca5209a521fc9a1967848cabc70f Mon Sep 17 00:00:00 2001 From: Oluwafikayo Sanni Date: Sat, 18 Mar 2023 14:45:39 +0100 Subject: [PATCH 1/4] embed errors instead of throwing Signed-off-by: Jadesola Bello --- src/ppx_inline_test.ml | 50 +++++++++++++++++++++++------------------- 1 file changed, 28 insertions(+), 22 deletions(-) diff --git a/src/ppx_inline_test.ml b/src/ppx_inline_test.ml index b4a00db..1b09325 100644 --- a/src/ppx_inline_test.ml +++ b/src/ppx_inline_test.ml @@ -40,10 +40,10 @@ let () = | "drop" -> maybe_drop_mode := Drop | "drop_with_deadcode" -> maybe_drop_mode := Drop_with_deadcode | s -> - Location.raise_errorf - ~loc:id.loc - "invalid 'inline-test' cookie (%s), expected one of: drop, drop_with_deadcode" - s)) + Ast_builder.Default.( + pexp_extension ~loc:id.loc + (Location.error_extensionf ~loc:id.loc + "invalid 'inline-test' cookie (%s), expected one of: drop, drop_with_deadcode"))) ;; (* Same as above, but for the Dune setting *) @@ -59,11 +59,12 @@ let () = | "disabled" -> maybe_drop_mode := Drop | "ignored" -> maybe_drop_mode := Drop_with_deadcode | s -> - Location.raise_errorf - ~loc:id.loc - "invalid 'inline_tests' cookie (%s), expected one of: enabled, disabled or \ - ignored" - s)) + Ast_builder.Default.( + pexp_extension ~loc:id.loc + (Location.error_extensionf ~loc:id.loc + "invalid 'inline_tests' cookie (%s), expected one of: enabled, disabled or \ + ignored" + ))) ;; let maybe_drop loc code = @@ -171,13 +172,15 @@ let validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags = Has_tests.set true; if not (can_use_test_extensions ()) then - Location.raise_errorf - ~loc - "%s: extension is disabled because the tests would be ignored (the build system \ - didn't pass -inline-test-lib. With jenga or dune, this usually happens when \ - writing tests in files that are part of an executable stanza, but only library \ - stanzas support inline tests)" - name_of_ppx_rewriter; + Ast_builder.Default.( + pexp_extension ~loc + (Location.error_extensionf ~loc + "%s: extension is disabled because the tests would be ignored (the build system \ + didn't pass -inline-test-lib. With jenga or dune, this usually happens when \ + writing tests in files that are part of an executable stanza, but only library \ + stanzas support inline tests)" + name_of_ppx_rewriter) + ) List.iter tags ~f:(fun tag -> match validate_tag tag with | Ok () -> () @@ -187,12 +190,15 @@ let validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags = | None -> "" | Some hint -> "\n" ^ hint in - Location.raise_errorf - ~loc - "%s: %S is not a valid tag for inline tests.%s" - name_of_ppx_rewriter - tag - hint) + Ast_builder.Default.( + pexp_extension ~loc + (Location.error_extensionf ~loc + "%s: %S is not a valid tag for inline tests.%s" + name_of_ppx_rewriter + tag + hint) + )) + ;; let name_of_ppx_rewriter = "ppx_inline_test" From 12e72c9cbda4a4c7afd9ad36f55647c01fd008e4 Mon Sep 17 00:00:00 2001 From: Oluwafikayo Sanni Date: Sun, 19 Mar 2023 19:23:21 +0100 Subject: [PATCH 2/4] chore: resolve missing args error --- src/ppx_inline_test.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/ppx_inline_test.ml b/src/ppx_inline_test.ml index 1b09325..d4333be 100644 --- a/src/ppx_inline_test.ml +++ b/src/ppx_inline_test.ml @@ -43,7 +43,9 @@ let () = Ast_builder.Default.( pexp_extension ~loc:id.loc (Location.error_extensionf ~loc:id.loc - "invalid 'inline-test' cookie (%s), expected one of: drop, drop_with_deadcode"))) + "invalid 'inline-test' cookie (%s), expected one of: drop, drop_with_deadcode"s)) + ) + ) ;; (* Same as above, but for the Dune setting *) @@ -64,7 +66,7 @@ let () = (Location.error_extensionf ~loc:id.loc "invalid 'inline_tests' cookie (%s), expected one of: enabled, disabled or \ ignored" - ))) + )))) ;; let maybe_drop loc code = From b294c321f4c37600c8b3119032f6d06687f6b385 Mon Sep 17 00:00:00 2001 From: Oluwafikayo Sanni Date: Wed, 22 Mar 2023 09:57:25 +0100 Subject: [PATCH 3/4] chore: change validate_extension_point_exn --- src/ppx_inline_test.ml | 79 ++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 41 deletions(-) diff --git a/src/ppx_inline_test.ml b/src/ppx_inline_test.ml index d4333be..838867a 100644 --- a/src/ppx_inline_test.ml +++ b/src/ppx_inline_test.ml @@ -40,12 +40,10 @@ let () = | "drop" -> maybe_drop_mode := Drop | "drop_with_deadcode" -> maybe_drop_mode := Drop_with_deadcode | s -> - Ast_builder.Default.( - pexp_extension ~loc:id.loc - (Location.error_extensionf ~loc:id.loc - "invalid 'inline-test' cookie (%s), expected one of: drop, drop_with_deadcode"s)) - ) - ) + Location.raise_errorf + ~loc:id.loc + "invalid 'inline-test' cookie (%s), expected one of: drop, drop_with_deadcode" + s)) ;; (* Same as above, but for the Dune setting *) @@ -61,12 +59,11 @@ let () = | "disabled" -> maybe_drop_mode := Drop | "ignored" -> maybe_drop_mode := Drop_with_deadcode | s -> - Ast_builder.Default.( - pexp_extension ~loc:id.loc - (Location.error_extensionf ~loc:id.loc - "invalid 'inline_tests' cookie (%s), expected one of: enabled, disabled or \ - ignored" - )))) + Location.raise_errorf + ~loc:id.loc + "invalid 'inline_tests' cookie (%s), expected one of: enabled, disabled or \ + ignored" + s)) ;; let maybe_drop loc code = @@ -171,38 +168,38 @@ let validate_tag tag = ;; let validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags = + let errors = ref [] in Has_tests.set true; - if not (can_use_test_extensions ()) - then - Ast_builder.Default.( - pexp_extension ~loc - (Location.error_extensionf ~loc - "%s: extension is disabled because the tests would be ignored (the build system \ - didn't pass -inline-test-lib. With jenga or dune, this usually happens when \ - writing tests in files that are part of an executable stanza, but only library \ - stanzas support inline tests)" - name_of_ppx_rewriter) - ) - List.iter tags ~f:(fun tag -> - match validate_tag tag with - | Ok () -> () - | Error hint -> - let hint = - match hint with - | None -> "" - | Some hint -> "\n" ^ hint - in - Ast_builder.Default.( - pexp_extension ~loc - (Location.error_extensionf ~loc - "%s: %S is not a valid tag for inline tests.%s" - name_of_ppx_rewriter - tag - hint) - )) - + if not (can_use_test_extensions ()) then + let error_msg = + Printf.sprintf + "%s: extension is disabled because the tests would be ignored (the build system \ + didn't pass -inline-test-lib. With jenga or dune, this usually happens when \ + writing tests in files that are part of an executable stanza, but only library \ + stanzas support inline tests)" + name_of_ppx_rewriter + in + errors := error_msg :: !errors + else + List.iter tags ~f:(fun tag -> + match validate_tag tag with + | Ok () -> () + | Error hint -> + let hint = + match hint with + | None -> "" + | Some hint -> "\n" ^ hint + in + let error_msg = + Printf.sprintf "%s: %S is not a valid tag for inline tests.%s" + name_of_ppx_rewriter tag hint + in + errors := error_msg :: !errors + ); + !errors ;; + let name_of_ppx_rewriter = "ppx_inline_test" let expand_test ~loc ~path:_ ~name:id ~tags e = From 772991e7a059f232c8960462713e252b34b2cff8 Mon Sep 17 00:00:00 2001 From: Oluwafikayo Sanni Date: Wed, 22 Mar 2023 10:52:00 +0100 Subject: [PATCH 4/4] chore: attempt at throwing exception lists --- src/ppx_inline_test.ml | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/src/ppx_inline_test.ml b/src/ppx_inline_test.ml index 838867a..5918df8 100644 --- a/src/ppx_inline_test.ml +++ b/src/ppx_inline_test.ml @@ -199,12 +199,25 @@ let validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags = !errors ;; - let name_of_ppx_rewriter = "ppx_inline_test" +let throw_exception_list ~loc ~(errs: string list) = + match errs with + | [] -> () (* list is empty, do nothing *) + | _ -> + let ast_builder = Ast_builder.make loc in + List.iter errs ~f:(fun err -> + (* loop through errs and raise an error for each one *) + Ast_builder.Default.( pexp_extension ~loc:loc + (Location.error_extensionf ~loc:loc err + )) + ) +;; + let expand_test ~loc ~path:_ ~name:id ~tags e = let loc = { loc with loc_ghost = true } in - validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags; + let errs = validate_extension_point_exn ~name:name_of_ppx_rewriter ~loc ~tags in + throw_exception_list loc errs; apply_to_descr "test" ~loc (Some e) id tags [%expr fun () -> [%e e]] ;;