From 2e9a5a09338f07a01c4e07fcb9024e72bd8f30fc Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Sun, 5 Feb 2023 07:51:52 +0100 Subject: [PATCH 1/6] add test for multiple signature items --- src_test/ppx_deriving/errors/run.t | 16 ++++++++++++++++ src_test/ppx_deriving/errors_lte_407/run.t | 11 +++++++++++ 2 files changed, 27 insertions(+) diff --git a/src_test/ppx_deriving/errors/run.t b/src_test/ppx_deriving/errors/run.t index a59764f..e05ef41 100644 --- a/src_test/ppx_deriving/errors/run.t +++ b/src_test/ppx_deriving/errors/run.t @@ -101,3 +101,19 @@ Cannot find module error ^^^^^^^^^ Error: [%import]: cannot find the module type M in Stuff.S [1] + +Multiple signature items + $ cat >test.ml < [%%import: + > type b = int + > type a = string] + > EOF + +OCaml 4.08 reports different numbers. +It's been fixed for later versions in https://github.com/ocaml/ocaml/pull/8541 + $ dune build 2>&1 | sed -r 's/(line|character)s? [0-9]+(-[0-9]+)?/\1s %NUMBER%/g' + File "test.ml", lines %NUMBER%, characters %NUMBER%: + 1 | [%%import: + 2 | type b = int + 3 | type a = string] + Error: [] expected diff --git a/src_test/ppx_deriving/errors_lte_407/run.t b/src_test/ppx_deriving/errors_lte_407/run.t index 5ec3a01..da8c997 100644 --- a/src_test/ppx_deriving/errors_lte_407/run.t +++ b/src_test/ppx_deriving/errors_lte_407/run.t @@ -87,3 +87,14 @@ Cannot find module error File "test.ml", line 1, characters 34-43: Error: [%import]: cannot find the module type M in Stuff.S [1] + +Multiple signature items + $ cat >test.ml < [%%import: + > type b = int + > type a = string] + > EOF + $ dune build + File "test.ml", line 1, characters 0-40: + Error: [] expected + [1] From 2fea5f2e5938b20f9da16d2a90885599f6dda9cd Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Sun, 5 Feb 2023 07:53:38 +0100 Subject: [PATCH 2/6] add test for module type decl in signature item --- src_test/ppx_deriving/test_intf.ml | 4 ++++ src_test/ppx_deriving/test_intf.mli | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/src_test/ppx_deriving/test_intf.ml b/src_test/ppx_deriving/test_intf.ml index af05751..e5d84e2 100644 --- a/src_test/ppx_deriving/test_intf.ml +++ b/src_test/ppx_deriving/test_intf.ml @@ -1 +1,5 @@ [%%import: type a = Stuff.a] + +module type Example = sig + module type InnerModule = [%import: (module Stuff.S_optional)] +end diff --git a/src_test/ppx_deriving/test_intf.mli b/src_test/ppx_deriving/test_intf.mli index af05751..e5d84e2 100644 --- a/src_test/ppx_deriving/test_intf.mli +++ b/src_test/ppx_deriving/test_intf.mli @@ -1 +1,5 @@ [%%import: type a = Stuff.a] + +module type Example = sig + module type InnerModule = [%import: (module Stuff.S_optional)] +end From de40fc01d3440d37b36a3e799f09fd5c85967361 Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Sun, 5 Feb 2023 07:54:34 +0100 Subject: [PATCH 3/6] add test for module type with --- src_test/ppx_deriving/test_ppx_import.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src_test/ppx_deriving/test_ppx_import.ml b/src_test/ppx_deriving/test_ppx_import.ml index b8ad8db..c769a7a 100644 --- a/src_test/ppx_deriving/test_ppx_import.ml +++ b/src_test/ppx_deriving/test_ppx_import.ml @@ -54,6 +54,16 @@ type package_type = module type Hashable = [%import: (module Hashtbl.HashedType)] +module type HashableWith = [%import: +(module Hashtbl.HashedType with type t = string)] + +module HashableWith : HashableWith = struct + type t + + let equal = String.equal + let hash = int_of_string +end + [%%import: type self_t = Test_self_import.t] let test_self_import _ctxt = From 807ae223c8bce38aedd2070bed267b3829844fca Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Wed, 8 Feb 2023 18:35:44 +0100 Subject: [PATCH 4/6] add more module type error cases --- src_test/ppx_deriving/errors/run.t | 180 +++++++++++++++++++++ src_test/ppx_deriving/errors_lte_407/run.t | 180 +++++++++++++++++++++ 2 files changed, 360 insertions(+) diff --git a/src_test/ppx_deriving/errors/run.t b/src_test/ppx_deriving/errors/run.t index e05ef41..2578aec 100644 --- a/src_test/ppx_deriving/errors/run.t +++ b/src_test/ppx_deriving/errors/run.t @@ -117,3 +117,183 @@ It's been fixed for later versions in https://github.com/ocaml/ocaml/pull/8541 2 | type b = int 3 | type a = string] Error: [] expected + +Ptyp + $ cat >test.ml < [%%import: string] + > EOF + + $ dune build + File "test.ml", line 1, characters 0-18: + 1 | [%%import: string] + ^^^^^^^^^^^^^^^^^^ + Error: PSig expected + [1] + +Inline module type declaration + $ cat >test.ml < module type Hashable = [%import: (module sig type t end)] + > EOF + + $ dune build + File "test.ml", line 1, characters 41-55: + 1 | module type Hashable = [%import: (module sig type t end)] + ^^^^^^^^^^^^^^ + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Functor + $ cat >test.ml < module type Foo = [%import: (module functor (M : sig end) -> sig end)] + > EOF + + $ dune build + File "test.ml", line 1, characters 44-68: + 1 | module type Foo = [%import: (module functor (M : sig end) -> sig end)] + ^^^^^^^^^^^^^^^^^^^^^^^^ + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Module type of + $ cat >test.ml < module type Example = [%import: (module type of A)] + > EOF + + $ dune build + File "test.ml", line 1, characters 40-44: + 1 | module type Example = [%import: (module type of A)] + ^^^^ + Error: Syntax error + [1] + +Pmty_extension + $ cat >test.ml < module type M = [%import: [%extension]] + > EOF + + $ dune build + File "test.ml", line 1, characters 26-38: + 1 | module type M = [%import: [%extension]] + ^^^^^^^^^^^^ + Error: package expected + [1] + +Pwith_module + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module StringHashable = StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-47: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module StringHashable = StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Pwith_modtype + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module type StringHashable = StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-52: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module type StringHashable = StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Pwith_typesubst + $ cat >test.ml < module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] + > EOF + + $ dune build + File "test.ml", line 1, characters 45-85: + 1 | module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: invalid package type: only 'with type t =' constraints are supported + [1] + +Pwith_modtypesubst + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module type StringHashable := StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-53: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module type StringHashable := StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Pwith_modsubst + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module StringHashable := StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-48: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module StringHashable := StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] diff --git a/src_test/ppx_deriving/errors_lte_407/run.t b/src_test/ppx_deriving/errors_lte_407/run.t index da8c997..5bd3a80 100644 --- a/src_test/ppx_deriving/errors_lte_407/run.t +++ b/src_test/ppx_deriving/errors_lte_407/run.t @@ -98,3 +98,183 @@ Multiple signature items File "test.ml", line 1, characters 0-40: Error: [] expected [1] + +Ptyp + $ cat >test.ml < [%%import: string] + > EOF + + $ dune build + File "test.ml", line 1, characters 0-18: + 1 | [%%import: string] + ^^^^^^^^^^^^^^^^^^ + Error: PSig expected + [1] + +Inline module type declaration + $ cat >test.ml < module type Hashable = [%import: (module sig type t end)] + > EOF + + $ dune build + File "test.ml", line 1, characters 41-55: + 1 | module type Hashable = [%import: (module sig type t end)] + ^^^^^^^^^^^^^^ + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Functor + $ cat >test.ml < module type Foo = [%import: (module functor (M : sig end) -> sig end)] + > EOF + + $ dune build + File "test.ml", line 1, characters 44-68: + 1 | module type Foo = [%import: (module functor (M : sig end) -> sig end)] + ^^^^^^^^^^^^^^^^^^^^^^^^ + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Module type of + $ cat >test.ml < module type Example = [%import: (module type of A)] + > EOF + + $ dune build + File "test.ml", line 1, characters 40-44: + 1 | module type Example = [%import: (module type of A)] + ^^^^ + Error: Syntax error + [1] + +Pmty_extension + $ cat >test.ml < module type M = [%import: [%extension]] + > EOF + + $ dune build + File "test.ml", line 1, characters 26-38: + 1 | module type M = [%import: [%extension]] + ^^^^^^^^^^^^ + Error: package expected + [1] + +Pwith_module + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module StringHashable = StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-47: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module StringHashable = StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Pwith_modtype + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module type StringHashable = StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-52: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module type StringHashable = StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Pwith_typesubst + $ cat >test.ml < module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] + > EOF + + $ dune build + File "test.ml", line 1, characters 45-85: + 1 | module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: invalid package type: only 'with type t =' constraints are supported + [1] + +Pwith_modtypesubst + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module type StringHashable := StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-53: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module type StringHashable := StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] + +Pwith_modsubst + $ cat >test.ml < module type StringHashable = sig + > type t = string + > val equal : t -> t -> bool + > val hash : t -> int + > end + > + > module StringHashable = struct + > type t = string + > let equal = (=) + > let hash = Hashtbl.hash + > end + > + > module type HashableWith = [%import: (module sig + > include module type of StringHashable + > end with module StringHashable := StringHashable)] + > EOF + + $ dune build + File "test.ml", lines 13-15, characters 45-48: + 13 | .............................................sig + 14 | include module type of StringHashable + 15 | end with module StringHashable := StringHashable.. + Error: invalid package type: only module type identifier and 'with type' constraints are supported + [1] From 4ebeb199dc54399e44f54c8280d9bd88db56671b Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Wed, 8 Feb 2023 17:09:49 +0100 Subject: [PATCH 5/6] implement new module type syntax --- src/ppx_import.ml | 170 ++++++++++++++++++--- src_test/ppx_deriving/errors/run.t | 124 ++++++++------- src_test/ppx_deriving/errors_lte_407/run.t | 118 +++++++------- src_test/ppx_deriving/test_intf.ml | 2 +- src_test/ppx_deriving/test_intf.mli | 2 +- src_test/ppx_deriving/test_ppx_import.ml | 12 +- src_test/ppx_deriving/test_self_import.ml | 2 +- 7 files changed, 275 insertions(+), 155 deletions(-) diff --git a/src/ppx_import.ml b/src/ppx_import.ml index c7700fc..660b65c 100644 --- a/src/ppx_import.ml +++ b/src/ppx_import.ml @@ -508,17 +508,54 @@ let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) : | [] -> [] | _ -> assert false -let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) = +let subst_of_constraint (const : Ppxlib.with_constraint) = let open Ppxlib in - try - let ({txt = lid; loc} as alias), subst = package_type in + match const with + | Parsetree.Pwith_type (longident, type_decl) -> ( + match type_decl with + | {ptype_manifest = Some core_type; _} -> (longident, core_type) + | {ptype_loc; _} -> + raise_error ~loc:ptype_loc "[%%import]: Not supported type_decl" ) + | Parsetree.Pwith_module ({loc; _}, _) -> + raise_error ~loc "[%%import]: Pwith_module constraint is not supported." + | Parsetree.Pwith_modtype ({loc; _}, _) -> + raise_error ~loc "[%%import]: Pwith_modtype constraint is not supported." + | Parsetree.Pwith_modtypesubst ({loc; _}, _) -> + raise_error ~loc + "[%%import]: Pwith_modtypesubst constraint is not supported." + | Parsetree.Pwith_typesubst ({loc; _}, _) -> + raise_error ~loc "[%%import]: Pwith_typesubst constraint is not supported." + | Parsetree.Pwith_modsubst ({loc; _}, _) -> + raise_error ~loc "[%%import]: Pwith_modsubst constraint is not supported." + +let rec module_type ~tool_name ~input_name ?(subst = []) modtype = + let open Ppxlib in + let {pmty_desc; pmty_loc; _} = modtype in + match pmty_desc with + | Pmty_signature _ -> + (* Ex: module type%import Hashable = sig ... end *) + raise_error ~loc:pmty_loc + "[%%import] inline module type declaration is not supported" + | Pmty_with (modtype, constraints) -> + let subst = constraints |> List.map subst_of_constraint in + module_type ~tool_name ~input_name ~subst modtype + | Pmty_functor (_, _) -> + raise_error ~loc:pmty_loc "[%%import] module type doesn't support functor" + | Pmty_typeof _ -> + raise_error ~loc:pmty_loc "[%%import] module type doesn't support typeof" + | Pmty_extension _ -> + raise_error ~loc:pmty_loc "[%%import] module type doesn't support extension" + | Pmty_alias _ -> + raise_error ~loc:pmty_loc "[%%import] module type doesn't support alias" + | Pmty_ident longident -> + let {txt = lid; loc} = longident in if tool_name = "ocamldep" then if is_self_reference ~input_name ~loc lid then (* Create a dummy module type to break the circular dependency *) Ast_helper.Mty.mk ~attrs:[] (Pmty_signature []) else (* Just put it as alias *) - Ast_helper.Mty.mk ~attrs:[] (Pmty_alias alias) + Ast_helper.Mty.mk ~attrs:[] (Pmty_alias longident) else Ppxlib.Ast_helper.with_default_loc loc (fun () -> let env = Lazy.force lazy_env in @@ -552,6 +589,19 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) = | {mtd_type = None; _} -> raise_error ~loc "Imported module is abstract" | _ -> raise_error ~loc "Imported module is indirectly defined" ) + +let module_type_decl ~tool_name ~input_name + (modtype_decl : Ppxlib.module_type_declaration) = + let open Ppxlib in + try + let {pmtd_type; pmtd_loc; _} = modtype_decl in + match pmtd_type with + | None -> + (* when there's nothing after the equal sign. Ex: module type%import Hashable *) + raise_error ~loc:pmtd_loc + "[%%import] module type declaration is missing the module type \ + definition" + | Some modtype -> module_type ~tool_name ~input_name modtype with Error {loc; error} -> let ext = Ppxlib.Location.error_extensionf ~loc "%s" error in Ast_builder.Default.pmty_extension ~loc ext @@ -574,27 +624,105 @@ let type_declaration_expand_intf ~ctxt rec_flag type_decls = in Ppxlib.Ast_builder.Default.(psig_type ~loc rec_flag type_decls) -let module_declaration_expand ~ctxt package_type = +let module_declaration_expand ~ctxt modtype_decl = + let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in let input_name = Ppxlib.Expansion_context.Extension.input_name ctxt in - module_type ~tool_name ~input_name package_type + let modtype = module_type_decl ~tool_name ~input_name modtype_decl in + let Ppxlib.{pmtd_name; pmtd_attributes; pmtd_loc; _} = modtype_decl in + let md_decl = + Ppxlib.Ast_helper.Mtd.mk ~loc:pmtd_loc ~attrs:pmtd_attributes pmtd_name + ~typ:modtype + in + Ppxlib.{pstr_desc = Pstr_modtype md_decl; pstr_loc = loc} + +let module_declaration_expand_intf ~ctxt modtype_decl = + let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in + let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in + let input_name = Ppxlib.Expansion_context.Extension.input_name ctxt in + let modtype = module_type_decl ~tool_name ~input_name modtype_decl in + let Ppxlib.{pmtd_name; pmtd_attributes; pmtd_loc; _} = modtype_decl in + let md_decl = + Ppxlib.Ast_helper.Mtd.mk ~loc:pmtd_loc ~attrs:pmtd_attributes pmtd_name + ~typ:modtype + in + Ppxlib.{psig_desc = Psig_modtype md_decl; psig_loc = loc} + +let type_declaration_expander ~ctxt payload = + let return_error e = + let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in + let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in + Ppxlib.Ast_builder.Default.pstr_extension ext [] ~loc + in + match payload with + | Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}] + |Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] -> + type_declaration_expand ~ctxt rec_flag type_decls + | Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}] + |Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] -> + module_declaration_expand ~ctxt modtype_decl + | Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] -> + return_error + "[%%import] Expected a type declaration or a module type declaration" + | Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) -> + return_error + "[%%import] Expected exactly one item in the structure or signature, but \ + found multiple items" + | Parsetree.PStr [] | Parsetree.PSig [] -> + return_error + "[%%import] Expected exactly one item in the structure or signature, but \ + found none" + | Parsetree.PTyp _ -> + return_error + "[%%import] Type pattern (PTyp) is not supported, only type and module \ + type declarations are allowed" + | Parsetree.PPat (_, _) -> + return_error + "[%%import] Pattern (PPat) is not supported, only type and module type \ + declarations are allowed" let type_declaration_extension = Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.structure_item - Ppxlib.Ast_pattern.( - psig (psig_type __ __ ^:: nil) ||| pstr (pstr_type __ __ ^:: nil) ) - type_declaration_expand + Ppxlib.Ast_pattern.(__) + type_declaration_expander + +let type_declaration_expander_intf ~ctxt payload = + let return_error e = + let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in + let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in + Ppxlib.Ast_builder.Default.psig_extension ext [] ~loc + in + match payload with + | Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}] + |Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] -> + type_declaration_expand_intf ~ctxt rec_flag type_decls + | Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}] + |Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] -> + module_declaration_expand_intf ~ctxt modtype_decl + | Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] -> + return_error + "[%%import] Expected a type declaration or a module type declaration" + | Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) -> + return_error + "[%%import] Expected exactly one item in the structure or signature, but \ + found multiple items" + | Parsetree.PStr [] | Parsetree.PSig [] -> + return_error + "[%%import] Expected exactly one item in the structure or signature, but \ + found none" + | Parsetree.PTyp _ -> + return_error + "[%%import] Type pattern (PTyp) is not supported, only type and module \ + type declarations are allowed" + | Parsetree.PPat (_, _) -> + return_error + "[%%import] Pattern (PPat) is not supported, only type and module type \ + declarations are allowed" let type_declaration_extension_intf = Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item - Ppxlib.Ast_pattern.( - psig (psig_type __ __ ^:: nil) ||| pstr (pstr_type __ __ ^:: nil) ) - type_declaration_expand_intf - -let module_declaration_extension = - Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.module_type - Ppxlib.Ast_pattern.(ptyp (ptyp_package __)) - module_declaration_expand + Ppxlib.Ast_pattern.(__) + type_declaration_expander_intf let type_declaration_rule = Ppxlib.Context_free.Rule.extension type_declaration_extension @@ -602,13 +730,7 @@ let type_declaration_rule = let type_declaration_rule_intf = Ppxlib.Context_free.Rule.extension type_declaration_extension_intf -let module_declaration_rule = - Ppxlib.Context_free.Rule.extension module_declaration_extension - let () = Ppxlib.Driver.V2.register_transformation - ~rules: - [ type_declaration_rule - ; module_declaration_rule - ; type_declaration_rule_intf ] + ~rules:[type_declaration_rule; type_declaration_rule_intf] "ppx_import" diff --git a/src_test/ppx_deriving/errors/run.t b/src_test/ppx_deriving/errors/run.t index 2578aec..b354522 100644 --- a/src_test/ppx_deriving/errors/run.t +++ b/src_test/ppx_deriving/errors/run.t @@ -38,13 +38,13 @@ Abstract module error > EOF $ cat >test.ml < module type T = [%import: (module Stuff.T)] + > module type%import T = Stuff.T > EOF $ dune build - File "test.ml", line 1, characters 34-41: - 1 | module type T = [%import: (module Stuff.T)] - ^^^^^^^ + File "test.ml", line 1, characters 23-30: + 1 | module type%import T = Stuff.T + ^^^^^^^ Error: Imported module is abstract [1] @@ -92,13 +92,13 @@ Cannot find module error > EOF $ cat >test.ml < module type A = [%import: (module Stuff.S.M)] + > module type%import A = Stuff.S.M > EOF $ dune build - File "test.ml", line 1, characters 34-43: - 1 | module type A = [%import: (module Stuff.S.M)] - ^^^^^^^^^ + File "test.ml", line 1, characters 23-32: + 1 | module type%import A = Stuff.S.M + ^^^^^^^^^ Error: [%import]: cannot find the module type M in Stuff.S [1] @@ -116,7 +116,8 @@ It's been fixed for later versions in https://github.com/ocaml/ocaml/pull/8541 1 | [%%import: 2 | type b = int 3 | type a = string] - Error: [] expected + Error: [%%import] Expected exactly one item in the structure or signature, + but found multiple items Ptyp $ cat >test.ml <test.ml < module type Hashable = [%import: (module sig type t end)] + > module type%import Hashable = sig type t end > EOF $ dune build - File "test.ml", line 1, characters 41-55: - 1 | module type Hashable = [%import: (module sig type t end)] - ^^^^^^^^^^^^^^ - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 1, characters 30-44: + 1 | module type%import Hashable = sig type t end + ^^^^^^^^^^^^^^ + Error: [%%import] inline module type declaration is not supported [1] Functor $ cat >test.ml < module type Foo = [%import: (module functor (M : sig end) -> sig end)] + > module type%import Foo = functor (M : sig end) -> sig end > EOF $ dune build - File "test.ml", line 1, characters 44-68: - 1 | module type Foo = [%import: (module functor (M : sig end) -> sig end)] - ^^^^^^^^^^^^^^^^^^^^^^^^ - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 1, characters 33-57: + 1 | module type%import Foo = functor (M : sig end) -> sig end + ^^^^^^^^^^^^^^^^^^^^^^^^ + Error: [%%import] module type doesn't support functor [1] Module type of $ cat >test.ml < module type Example = [%import: (module type of A)] + > module type%import Example = module type of A > EOF $ dune build - File "test.ml", line 1, characters 40-44: - 1 | module type Example = [%import: (module type of A)] - ^^^^ - Error: Syntax error + File "test.ml", line 1, characters 29-45: + 1 | module type%import Example = module type of A + ^^^^^^^^^^^^^^^^ + Error: [%%import] module type doesn't support typeof [1] Pmty_extension $ cat >test.ml < module type M = [%import: [%extension]] + > module type%import M = [%extension] > EOF $ dune build - File "test.ml", line 1, characters 26-38: - 1 | module type M = [%import: [%extension]] - ^^^^^^^^^^^^ - Error: package expected + File "test.ml", line 1, characters 23-35: + 1 | module type%import M = [%extension] + ^^^^^^^^^^^^ + Error: [%%import] module type doesn't support extension [1] Pwith_module @@ -192,17 +194,16 @@ Pwith_module > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module StringHashable = StringHashable)] + > end with module StringHashable = StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-47: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module StringHashable = StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 16-30: + 15 | end with module StringHashable = StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_module constraint is not supported. [1] Pwith_modtype @@ -219,29 +220,28 @@ Pwith_modtype > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module type StringHashable = StringHashable)] + > end with module type StringHashable = StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-52: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module type StringHashable = StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 21-35: + 15 | end with module type StringHashable = StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_modtype constraint is not supported. [1] Pwith_typesubst $ cat >test.ml < module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] + > module type%import HashableWith = Hashtbl.HashedType with type t := string > EOF $ dune build - File "test.ml", line 1, characters 45-85: - 1 | module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: invalid package type: only 'with type t =' constraints are supported + File "test.ml", line 1, characters 63-64: + 1 | module type%import HashableWith = Hashtbl.HashedType with type t := string + ^ + Error: [%%import]: Pwith_typesubst constraint is not supported. [1] Pwith_modtypesubst @@ -258,17 +258,16 @@ Pwith_modtypesubst > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module type StringHashable := StringHashable)] + > end with module type StringHashable := StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-53: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module type StringHashable := StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 21-35: + 15 | end with module type StringHashable := StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_modtypesubst constraint is not supported. [1] Pwith_modsubst @@ -285,15 +284,14 @@ Pwith_modsubst > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module StringHashable := StringHashable)] + > end with module StringHashable := StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-48: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module StringHashable := StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 16-30: + 15 | end with module StringHashable := StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_modsubst constraint is not supported. [1] diff --git a/src_test/ppx_deriving/errors_lte_407/run.t b/src_test/ppx_deriving/errors_lte_407/run.t index 5bd3a80..38be1ec 100644 --- a/src_test/ppx_deriving/errors_lte_407/run.t +++ b/src_test/ppx_deriving/errors_lte_407/run.t @@ -34,11 +34,13 @@ Abstract module error > EOF $ cat >test.ml < module type T = [%import: (module Stuff.T)] + > module type%import T = Stuff.T > EOF $ dune build - File "test.ml", line 1, characters 34-41: + File "test.ml", line 1, characters 23-30: + 1 | module type%import T = Stuff.T + ^^^^^^^ Error: Imported module is abstract [1] @@ -80,11 +82,13 @@ Cannot find module error > EOF $ cat >test.ml < module type A = [%import: (module Stuff.S.M)] + > module type%import A = Stuff.S.M > EOF $ dune build - File "test.ml", line 1, characters 34-43: + File "test.ml", line 1, characters 23-32: + 1 | module type%import A = Stuff.S.M + ^^^^^^^^^ Error: [%import]: cannot find the module type M in Stuff.S [1] @@ -108,55 +112,57 @@ Ptyp File "test.ml", line 1, characters 0-18: 1 | [%%import: string] ^^^^^^^^^^^^^^^^^^ - Error: PSig expected + Error: [%%import] Invalid extension usage. [%%import] only supports structure + items, signatures or type declarations, but a type pattern (PTyp) was + found. [1] Inline module type declaration $ cat >test.ml < module type Hashable = [%import: (module sig type t end)] + > module type%import Hashable = sig type t end > EOF $ dune build - File "test.ml", line 1, characters 41-55: - 1 | module type Hashable = [%import: (module sig type t end)] - ^^^^^^^^^^^^^^ - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 1, characters 30-44: + 1 | module type%import Hashable = sig type t end + ^^^^^^^^^^^^^^ + Error: [%%import] inline module type declaration is not supported [1] Functor $ cat >test.ml < module type Foo = [%import: (module functor (M : sig end) -> sig end)] + > module type%import Foo = functor (M : sig end) -> sig end > EOF $ dune build - File "test.ml", line 1, characters 44-68: - 1 | module type Foo = [%import: (module functor (M : sig end) -> sig end)] - ^^^^^^^^^^^^^^^^^^^^^^^^ - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 1, characters 33-57: + 1 | module type%import Foo = functor (M : sig end) -> sig end + ^^^^^^^^^^^^^^^^^^^^^^^^ + Error: [%%import] module type doesn't support functor [1] Module type of $ cat >test.ml < module type Example = [%import: (module type of A)] + > module type%import Example = module type of A > EOF $ dune build - File "test.ml", line 1, characters 40-44: - 1 | module type Example = [%import: (module type of A)] - ^^^^ - Error: Syntax error + File "test.ml", line 1, characters 29-45: + 1 | module type%import Example = module type of A + ^^^^^^^^^^^^^^^^ + Error: [%%import] module type doesn't support typeof [1] Pmty_extension $ cat >test.ml < module type M = [%import: [%extension]] + > module type%import M = [%extension] > EOF $ dune build - File "test.ml", line 1, characters 26-38: - 1 | module type M = [%import: [%extension]] - ^^^^^^^^^^^^ - Error: package expected + File "test.ml", line 1, characters 23-35: + 1 | module type%import M = [%extension] + ^^^^^^^^^^^^ + Error: [%%import] module type doesn't support extension [1] Pwith_module @@ -173,17 +179,16 @@ Pwith_module > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module StringHashable = StringHashable)] + > end with module StringHashable = StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-47: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module StringHashable = StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 16-30: + 15 | end with module StringHashable = StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_module constraint is not supported. [1] Pwith_modtype @@ -200,29 +205,28 @@ Pwith_modtype > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module type StringHashable = StringHashable)] + > end with module type StringHashable = StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-52: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module type StringHashable = StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 21-35: + 15 | end with module type StringHashable = StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_modtype constraint is not supported. [1] Pwith_typesubst $ cat >test.ml < module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] + > module type%import HashableWith = Hashtbl.HashedType with type t := string > EOF $ dune build - File "test.ml", line 1, characters 45-85: - 1 | module type HashableWith = [%import: (module Hashtbl.HashedType with type t := string)] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: invalid package type: only 'with type t =' constraints are supported + File "test.ml", line 1, characters 63-64: + 1 | module type%import HashableWith = Hashtbl.HashedType with type t := string + ^ + Error: [%%import]: Pwith_typesubst constraint is not supported. [1] Pwith_modtypesubst @@ -239,17 +243,16 @@ Pwith_modtypesubst > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module type StringHashable := StringHashable)] + > end with module type StringHashable := StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-53: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module type StringHashable := StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 21-35: + 15 | end with module type StringHashable := StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_modtypesubst constraint is not supported. [1] Pwith_modsubst @@ -266,15 +269,14 @@ Pwith_modsubst > let hash = Hashtbl.hash > end > - > module type HashableWith = [%import: (module sig + > module type%import HashableWith = sig > include module type of StringHashable - > end with module StringHashable := StringHashable)] + > end with module StringHashable := StringHashable > EOF $ dune build - File "test.ml", lines 13-15, characters 45-48: - 13 | .............................................sig - 14 | include module type of StringHashable - 15 | end with module StringHashable := StringHashable.. - Error: invalid package type: only module type identifier and 'with type' constraints are supported + File "test.ml", line 15, characters 16-30: + 15 | end with module StringHashable := StringHashable + ^^^^^^^^^^^^^^ + Error: [%%import]: Pwith_modsubst constraint is not supported. [1] diff --git a/src_test/ppx_deriving/test_intf.ml b/src_test/ppx_deriving/test_intf.ml index e5d84e2..e3bedf5 100644 --- a/src_test/ppx_deriving/test_intf.ml +++ b/src_test/ppx_deriving/test_intf.ml @@ -1,5 +1,5 @@ [%%import: type a = Stuff.a] module type Example = sig - module type InnerModule = [%import: (module Stuff.S_optional)] + module type%import InnerModule = Stuff.S_optional end diff --git a/src_test/ppx_deriving/test_intf.mli b/src_test/ppx_deriving/test_intf.mli index e5d84e2..e3bedf5 100644 --- a/src_test/ppx_deriving/test_intf.mli +++ b/src_test/ppx_deriving/test_intf.mli @@ -1,5 +1,5 @@ [%%import: type a = Stuff.a] module type Example = sig - module type InnerModule = [%import: (module Stuff.S_optional)] + module type%import InnerModule = Stuff.S_optional end diff --git a/src_test/ppx_deriving/test_ppx_import.ml b/src_test/ppx_deriving/test_ppx_import.ml index c769a7a..e010c97 100644 --- a/src_test/ppx_deriving/test_ppx_import.ml +++ b/src_test/ppx_deriving/test_ppx_import.ml @@ -16,7 +16,7 @@ module MI = Stuff.MI [%%import: type i = Stuff.i] -module type S_rec = [%import: (module Stuff.S_rec)] +module type%import S_rec = Stuff.S_rec let test_constr _ctxt = ignore [A1; A2 "a"]; @@ -34,7 +34,7 @@ let test_constr _ctxt = let test_deriving _ctxt = assert_equal ~printer:(fun x -> x) "(Stuff.A2 \"a\")" (show_a' (A2 "a")) -module type S_optional = [%import: (module Stuff.S_optional)] +module type%import S_optional = Stuff.S_optional module Test_optional : S_optional = struct let f ?(opt = 0) () = ignore opt @@ -52,10 +52,8 @@ type package_type = Longident.t := (Longident.t [@printer pp_longident])] ) [@@deriving show]] -module type Hashable = [%import: (module Hashtbl.HashedType)] - -module type HashableWith = [%import: -(module Hashtbl.HashedType with type t = string)] +module type%import Hashable = Hashtbl.HashedType +module type%import HashableWith = Hashtbl.HashedType with type t = string module HashableWith : HashableWith = struct type t @@ -70,7 +68,7 @@ let test_self_import _ctxt = let v : self_t = `OptionA in Test_self_import.validate_option v -module type Self_S = [%import: (module Test_self_import.S)] +module type%import Self_S = Test_self_import.S module Self_M : Self_S = struct let test () = "test" diff --git a/src_test/ppx_deriving/test_self_import.ml b/src_test/ppx_deriving/test_self_import.ml index 3f03f3f..8001808 100644 --- a/src_test/ppx_deriving/test_self_import.ml +++ b/src_test/ppx_deriving/test_self_import.ml @@ -1,6 +1,6 @@ [%%import: type t = Test_self_import.t] -module type S = [%import: (module Test_self_import.S)] +module type%import S = Test_self_import.S let validate_option = function | `OptionA -> assert true From ab733dacc56de3daa658534156f3b5bde3d25be4 Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Thu, 23 Feb 2023 18:09:21 +0100 Subject: [PATCH 6/6] merge extractors --- src/ppx_import.ml | 131 +++++++++------------ src_test/ppx_deriving/errors/run.t | 6 +- src_test/ppx_deriving/errors_lte_407/run.t | 38 +----- 3 files changed, 63 insertions(+), 112 deletions(-) diff --git a/src/ppx_import.ml b/src/ppx_import.ml index 660b65c..e85fa4f 100644 --- a/src/ppx_import.ml +++ b/src/ppx_import.ml @@ -536,9 +536,6 @@ let rec module_type ~tool_name ~input_name ?(subst = []) modtype = (* Ex: module type%import Hashable = sig ... end *) raise_error ~loc:pmty_loc "[%%import] inline module type declaration is not supported" - | Pmty_with (modtype, constraints) -> - let subst = constraints |> List.map subst_of_constraint in - module_type ~tool_name ~input_name ~subst modtype | Pmty_functor (_, _) -> raise_error ~loc:pmty_loc "[%%import] module type doesn't support functor" | Pmty_typeof _ -> @@ -547,6 +544,9 @@ let rec module_type ~tool_name ~input_name ?(subst = []) modtype = raise_error ~loc:pmty_loc "[%%import] module type doesn't support extension" | Pmty_alias _ -> raise_error ~loc:pmty_loc "[%%import] module type doesn't support alias" + | Pmty_with (modtype, constraints) -> + let subst = constraints |> List.map subst_of_constraint in + module_type ~tool_name ~input_name ~subst modtype | Pmty_ident longident -> let {txt = lid; loc} = longident in if tool_name = "ocamldep" then @@ -648,89 +648,68 @@ let module_declaration_expand_intf ~ctxt modtype_decl = in Ppxlib.{psig_desc = Psig_modtype md_decl; psig_loc = loc} -let type_declaration_expander ~ctxt payload = - let return_error e = - let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in - let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in - Ppxlib.Ast_builder.Default.pstr_extension ext [] ~loc - in +type extracted_payload = + | Type_decl of Ppxlib.rec_flag * Ppxlib.type_declaration list + | Module_type_decl of Ppxlib.module_type_declaration + +let type_extractor = + Ppxlib.Ast_pattern.( + pstr (pstr_type __ __ ^:: nil) + ||| psig (psig_type __ __ ^:: nil) + |> map2 ~f:(fun rec_flag type_decl -> Type_decl (rec_flag, type_decl)) ) + +let module_type_extractor = + Ppxlib.Ast_pattern.( + psig (psig_modtype __ ^:: nil) + ||| pstr (pstr_modtype __ ^:: nil) + |> map1 ~f:(fun modtype -> Module_type_decl modtype) ) + +let extractor = Ppxlib.Ast_pattern.(type_extractor ||| module_type_extractor) + +let expander ~ctxt payload = match payload with - | Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}] - |Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] -> + | Type_decl (rec_flag, type_decls) -> type_declaration_expand ~ctxt rec_flag type_decls - | Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}] - |Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] -> + | Module_type_decl modtype_decl -> module_declaration_expand ~ctxt modtype_decl - | Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] -> - return_error - "[%%import] Expected a type declaration or a module type declaration" - | Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) -> - return_error - "[%%import] Expected exactly one item in the structure or signature, but \ - found multiple items" - | Parsetree.PStr [] | Parsetree.PSig [] -> - return_error - "[%%import] Expected exactly one item in the structure or signature, but \ - found none" - | Parsetree.PTyp _ -> - return_error - "[%%import] Type pattern (PTyp) is not supported, only type and module \ - type declarations are allowed" - | Parsetree.PPat (_, _) -> - return_error - "[%%import] Pattern (PPat) is not supported, only type and module type \ - declarations are allowed" - -let type_declaration_extension = + +let import_extension = Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.structure_item - Ppxlib.Ast_pattern.(__) - type_declaration_expander - -let type_declaration_expander_intf ~ctxt payload = - let return_error e = - let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in - let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in - Ppxlib.Ast_builder.Default.psig_extension ext [] ~loc - in + extractor expander + +let import_declaration_rule = + Ppxlib.Context_free.Rule.extension import_extension + +let type_extractor_intf = + Ppxlib.Ast_pattern.( + pstr (pstr_type __ __ ^:: nil) + ||| psig (psig_type __ __ ^:: nil) + |> map2 ~f:(fun rec_flag type_decl -> Type_decl (rec_flag, type_decl)) ) + +let module_type_extractor_intf = + Ppxlib.Ast_pattern.( + psig (psig_modtype __ ^:: nil) + ||| pstr (pstr_modtype __ ^:: nil) + |> map1 ~f:(fun modtype -> Module_type_decl modtype) ) + +let extractor_intf = + Ppxlib.Ast_pattern.(type_extractor_intf ||| module_type_extractor_intf) + +let expander_intf ~ctxt payload = match payload with - | Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}] - |Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] -> + | Type_decl (rec_flag, type_decls) -> type_declaration_expand_intf ~ctxt rec_flag type_decls - | Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}] - |Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] -> + | Module_type_decl modtype_decl -> module_declaration_expand_intf ~ctxt modtype_decl - | Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] -> - return_error - "[%%import] Expected a type declaration or a module type declaration" - | Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) -> - return_error - "[%%import] Expected exactly one item in the structure or signature, but \ - found multiple items" - | Parsetree.PStr [] | Parsetree.PSig [] -> - return_error - "[%%import] Expected exactly one item in the structure or signature, but \ - found none" - | Parsetree.PTyp _ -> - return_error - "[%%import] Type pattern (PTyp) is not supported, only type and module \ - type declarations are allowed" - | Parsetree.PPat (_, _) -> - return_error - "[%%import] Pattern (PPat) is not supported, only type and module type \ - declarations are allowed" - -let type_declaration_extension_intf = - Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item - Ppxlib.Ast_pattern.(__) - type_declaration_expander_intf -let type_declaration_rule = - Ppxlib.Context_free.Rule.extension type_declaration_extension +let import_extension_intf = + Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item + extractor_intf expander_intf -let type_declaration_rule_intf = - Ppxlib.Context_free.Rule.extension type_declaration_extension_intf +let import_declaration_rule_intf = + Ppxlib.Context_free.Rule.extension import_extension_intf let () = Ppxlib.Driver.V2.register_transformation - ~rules:[type_declaration_rule; type_declaration_rule_intf] + ~rules:[import_declaration_rule; import_declaration_rule_intf] "ppx_import" diff --git a/src_test/ppx_deriving/errors/run.t b/src_test/ppx_deriving/errors/run.t index b354522..7186e1a 100644 --- a/src_test/ppx_deriving/errors/run.t +++ b/src_test/ppx_deriving/errors/run.t @@ -116,8 +116,7 @@ It's been fixed for later versions in https://github.com/ocaml/ocaml/pull/8541 1 | [%%import: 2 | type b = int 3 | type a = string] - Error: [%%import] Expected exactly one item in the structure or signature, - but found multiple items + Error: [] expected Ptyp $ cat >test.ml < EOF $ dune build - File "test.ml", line 1, characters 33-57: - 1 | module type%import Foo = functor (M : sig end) -> sig end - ^^^^^^^^^^^^^^^^^^^^^^^^ + File "test.ml", line 1, characters 25-57: Error: [%%import] module type doesn't support functor [1] @@ -148,8 +136,6 @@ Module type of $ dune build File "test.ml", line 1, characters 29-45: - 1 | module type%import Example = module type of A - ^^^^^^^^^^^^^^^^ Error: [%%import] module type doesn't support typeof [1] @@ -160,8 +146,6 @@ Pmty_extension $ dune build File "test.ml", line 1, characters 23-35: - 1 | module type%import M = [%extension] - ^^^^^^^^^^^^ Error: [%%import] module type doesn't support extension [1] @@ -186,8 +170,6 @@ Pwith_module $ dune build File "test.ml", line 15, characters 16-30: - 15 | end with module StringHashable = StringHashable - ^^^^^^^^^^^^^^ Error: [%%import]: Pwith_module constraint is not supported. [1] @@ -211,10 +193,8 @@ Pwith_modtype > EOF $ dune build - File "test.ml", line 15, characters 21-35: - 15 | end with module type StringHashable = StringHashable - ^^^^^^^^^^^^^^ - Error: [%%import]: Pwith_modtype constraint is not supported. + File "test.ml", line 15, characters 16-20: + Error: Syntax error [1] Pwith_typesubst @@ -224,8 +204,6 @@ Pwith_typesubst $ dune build File "test.ml", line 1, characters 63-64: - 1 | module type%import HashableWith = Hashtbl.HashedType with type t := string - ^ Error: [%%import]: Pwith_typesubst constraint is not supported. [1] @@ -249,10 +227,8 @@ Pwith_modtypesubst > EOF $ dune build - File "test.ml", line 15, characters 21-35: - 15 | end with module type StringHashable := StringHashable - ^^^^^^^^^^^^^^ - Error: [%%import]: Pwith_modtypesubst constraint is not supported. + File "test.ml", line 15, characters 16-20: + Error: Syntax error [1] Pwith_modsubst @@ -276,7 +252,5 @@ Pwith_modsubst $ dune build File "test.ml", line 15, characters 16-30: - 15 | end with module StringHashable := StringHashable - ^^^^^^^^^^^^^^ Error: [%%import]: Pwith_modsubst constraint is not supported. [1]