diff --git a/src/ppx_import.ml b/src/ppx_import.ml index c7700fc..e85fa4f 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_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_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 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,41 +624,92 @@ 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 type_declaration_extension = +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} + +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 + | Type_decl (rec_flag, type_decls) -> + type_declaration_expand ~ctxt rec_flag type_decls + | Module_type_decl modtype_decl -> + module_declaration_expand ~ctxt modtype_decl + +let import_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 - -let type_declaration_extension_intf = + 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 + | Type_decl (rec_flag, type_decls) -> + type_declaration_expand_intf ~ctxt rec_flag type_decls + | Module_type_decl modtype_decl -> + module_declaration_expand_intf ~ctxt modtype_decl + +let import_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 - -let type_declaration_rule = - Ppxlib.Context_free.Rule.extension type_declaration_extension - -let type_declaration_rule_intf = - Ppxlib.Context_free.Rule.extension type_declaration_extension_intf + extractor_intf expander_intf -let module_declaration_rule = - Ppxlib.Context_free.Rule.extension module_declaration_extension +let import_declaration_rule_intf = + Ppxlib.Context_free.Rule.extension import_extension_intf let () = Ppxlib.Driver.V2.register_transformation - ~rules: - [ type_declaration_rule - ; module_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 a59764f..7186e1a 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,12 +92,204 @@ 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] + +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 + +Ptyp + $ cat >test.ml < [%%import: string] + > EOF + + $ dune build + File "test.ml", line 1, characters 0-18: + 1 | [%%import: string] + ^^^^^^^^^^^^^^^^^^ + Error: PStr expected + [1] + +Inline module type declaration + $ cat >test.ml < module type%import Hashable = sig type t end + > EOF + + $ dune build + 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%import Foo = functor (M : sig end) -> sig end + > EOF + + $ dune build + 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%import Example = module type of A + > EOF + + $ 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] + +Pmty_extension + $ cat >test.ml < module type%import M = [%extension] + > EOF + + $ 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] + +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%import HashableWith = sig + > include module type of StringHashable + > end with module StringHashable = StringHashable + > EOF + + $ 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] + +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%import HashableWith = sig + > include module type of StringHashable + > end with module type StringHashable = StringHashable + > 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. + [1] + +Pwith_typesubst + $ cat >test.ml < module type%import HashableWith = Hashtbl.HashedType with type t := string + > EOF + + $ 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] + +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%import HashableWith = sig + > include module type of StringHashable + > end with module type StringHashable := StringHashable + > 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. + [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%import HashableWith = sig + > include module type of StringHashable + > end with module StringHashable := StringHashable + > EOF + + $ 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] diff --git a/src_test/ppx_deriving/errors_lte_407/run.t b/src_test/ppx_deriving/errors_lte_407/run.t index 5ec3a01..74d37c1 100644 --- a/src_test/ppx_deriving/errors_lte_407/run.t +++ b/src_test/ppx_deriving/errors_lte_407/run.t @@ -34,11 +34,11 @@ 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: Error: Imported module is abstract [1] @@ -80,10 +80,177 @@ 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: 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] + +Ptyp + $ cat >test.ml < [%%import: string] + > EOF + + $ dune build + File "test.ml", line 1, characters 0-18: + Error: PStr expected + [1] + +Inline module type declaration + $ cat >test.ml < module type%import Hashable = sig type t end + > EOF + + $ dune build + File "test.ml", line 1, characters 30-44: + Error: [%%import] inline module type declaration is not supported + [1] + +Functor + $ cat >test.ml < module type%import Foo = functor (M : sig end) -> sig end + > EOF + + $ dune build + File "test.ml", line 1, characters 25-57: + Error: [%%import] module type doesn't support functor + [1] + +Module type of + $ cat >test.ml < module type%import Example = module type of A + > EOF + + $ dune build + File "test.ml", line 1, characters 29-45: + Error: [%%import] module type doesn't support typeof + [1] + +Pmty_extension + $ cat >test.ml < module type%import M = [%extension] + > EOF + + $ dune build + File "test.ml", line 1, characters 23-35: + Error: [%%import] module type doesn't support extension + [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%import HashableWith = sig + > include module type of StringHashable + > end with module StringHashable = StringHashable + > EOF + + $ dune build + File "test.ml", line 15, characters 16-30: + Error: [%%import]: Pwith_module constraint is not 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%import HashableWith = sig + > include module type of StringHashable + > end with module type StringHashable = StringHashable + > EOF + + $ dune build + File "test.ml", line 15, characters 16-20: + Error: Syntax error + [1] + +Pwith_typesubst + $ cat >test.ml < module type%import HashableWith = Hashtbl.HashedType with type t := string + > EOF + + $ dune build + File "test.ml", line 1, characters 63-64: + Error: [%%import]: Pwith_typesubst constraint is not 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%import HashableWith = sig + > include module type of StringHashable + > end with module type StringHashable := StringHashable + > EOF + + $ dune build + File "test.ml", line 15, characters 16-20: + Error: Syntax error + [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%import HashableWith = sig + > include module type of StringHashable + > end with module StringHashable := StringHashable + > EOF + + $ dune build + File "test.ml", line 15, characters 16-30: + 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 af05751..e3bedf5 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%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 af05751..e3bedf5 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%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 b8ad8db..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,7 +52,15 @@ type package_type = Longident.t := (Longident.t [@printer pp_longident])] ) [@@deriving show]] -module type Hashable = [%import: (module Hashtbl.HashedType)] +module type%import Hashable = Hashtbl.HashedType +module type%import HashableWith = 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] @@ -60,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