From 47e5cb04ff77689034753bd0b70ce40c2c534b84 Mon Sep 17 00:00:00 2001 From: tatchi Date: Wed, 2 Feb 2022 18:14:52 +0100 Subject: [PATCH 1/5] implement new syntax --- src/ppx_import.ml | 122 +++++++++++------- src_test/ppx_deriving/test_intf.ml | 2 +- src_test/ppx_deriving/test_intf.mli | 2 +- src_test/ppx_deriving/test_ppx_import.ml | 42 +++--- src_test/ppx_deriving/test_self_import.ml | 2 +- .../test_ppx_deriving_sexp.ml | 2 +- 6 files changed, 97 insertions(+), 75 deletions(-) diff --git a/src/ppx_import.ml b/src/ppx_import.ml index 3c4c828..ed5d224 100644 --- a/src/ppx_import.ml +++ b/src/ppx_import.ml @@ -369,52 +369,48 @@ let type_declaration ~tool_name ~input_name (type_decl : Ppxlib.type_declaration | { ptype_attributes ; ptype_name ; ptype_manifest = - Some {ptyp_desc = Ptyp_extension ({txt = "import"; loc}, payload); _} - ; _ } -> ( - match payload with - | PTyp ({ptyp_desc = Ptyp_constr ({txt = lid; loc}, _); _} as manifest) -> - if tool_name = "ocamldep" then - (* Just put it as manifest *) - if is_self_reference ~input_name lid then - {type_decl with ptype_manifest = None} - else {type_decl with ptype_manifest = Some manifest} - else - Ast_helper.with_default_loc loc (fun () -> - let ttype_decl = - let env = Lazy.force lazy_env in - match lid with - | Lapply _ -> - Location.raise_errorf ~loc - "[%%import] cannot import a functor application %s" - (string_of_lid lid) - | Lident _ as head_id -> - (* In this case, we know for sure that the user intends this lident - as a type name, so we use Typetexp.find_type and let the failure - cases propagate to the user. *) - Compat.find_type env ~loc head_id |> snd - | Ldot (parent_id, elem) -> - let sig_items = locate_sig ~loc env parent_id in - get_type_decl ~loc sig_items parent_id elem - in - let m, s = - if is_self_reference ~input_name lid then (None, []) - else - let subst = subst_of_manifest manifest in - let subst = - subst - @ [ ( `Lid (Lident (Longident.last_exn lid)) - , Ast_helper.Typ.constr - {txt = Lident ptype_name.txt; loc = ptype_name.loc} - [] ) ] - in - (Some manifest, subst) - in - let ptype_decl = - ptype_decl_of_ttype_decl ~manifest:m ~subst:s ptype_name - ttype_decl - in - {ptype_decl with ptype_attributes} ) - | _ -> Location.raise_errorf ~loc "Invalid [%%import] syntax" ) + Some ({ptyp_desc = Ptyp_constr ({txt = lid; loc}, _); _} as manifest) + ; _ } -> + if tool_name = "ocamldep" then + (* Just put it as manifest *) + if is_self_reference ~input_name lid then + {type_decl with ptype_manifest = None} + else {type_decl with ptype_manifest = Some manifest} + else + Ast_helper.with_default_loc loc (fun () -> + let ttype_decl = + let env = Lazy.force lazy_env in + match lid with + | Lapply _ -> + Location.raise_errorf ~loc + "[%%import] cannot import a functor application %s" + (string_of_lid lid) + | Lident _ as head_id -> + (* In this case, we know for sure that the user intends this lident + as a type name, so we use Typetexp.find_type and let the failure + cases propagate to the user. *) + Compat.find_type env ~loc head_id |> snd + | Ldot (parent_id, elem) -> + let sig_items = locate_sig ~loc env parent_id in + get_type_decl ~loc sig_items parent_id elem + in + let m, s = + if is_self_reference ~input_name lid then (None, []) + else + let subst = subst_of_manifest manifest in + let subst = + subst + @ [ ( `Lid (Lident (Longident.last_exn lid)) + , Ast_helper.Typ.constr + {txt = Lident ptype_name.txt; loc = ptype_name.loc} + [] ) ] + in + (Some manifest, subst) + in + let ptype_decl = + ptype_decl_of_ttype_decl ~manifest:m ~subst:s ptype_name ttype_decl + in + {ptype_decl with ptype_attributes} ) | _ -> type_decl let rec cut_tsig_block_of_rec_types accu (tsig : Compat.signature_item_407 list) @@ -505,10 +501,19 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) = | _ -> Location.raise_errorf ~loc "Imported module is indirectly defined" ) -let type_declaration_expand ~ctxt type_decl = +let type_declaration_expand ~ctxt rec_flag type_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 - type_declaration ~tool_name ~input_name type_decl + let type_decl = type_declaration ~tool_name ~input_name type_decl in + Ppxlib.{pstr_desc = Pstr_type (rec_flag, [type_decl]); pstr_loc = loc} + +let type_declaration_expand_intf ~ctxt rec_flag type_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 type_decl = type_declaration ~tool_name ~input_name type_decl in + Ppxlib.{psig_desc = Psig_type (rec_flag, [type_decl]); psig_loc = loc} let module_declaration_expand ~ctxt package_type = let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in @@ -516,7 +521,18 @@ let module_declaration_expand ~ctxt package_type = module_type ~tool_name ~input_name package_type let type_declaration_extension = - Ppxlib.Extension.__declare_ppx_import "import" type_declaration_expand + Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.structure_item + Ppxlib.Ast_pattern.( + psig (psig_type __ (__ ^:: nil) ^:: nil) + ||| pstr (pstr_type __ (__ ^:: nil) ^:: nil)) + type_declaration_expand + +let type_declaration_extension_intf = + Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item + Ppxlib.Ast_pattern.( + psig (psig_type __ (__ ^:: nil) ^:: nil) + ||| pstr (pstr_type __ (__ ^:: nil) ^:: nil)) + type_declaration_expand_intf let module_declaration_extension = Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.module_type @@ -526,10 +542,16 @@ let module_declaration_extension = 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 + let module_declaration_rule = Ppxlib.Context_free.Rule.extension module_declaration_extension let () = Ppxlib.Driver.register_transformation - ~rules:[type_declaration_rule; module_declaration_rule] + ~rules: + [ type_declaration_rule + ; module_declaration_rule + ; type_declaration_rule_intf ] "ppx_import" diff --git a/src_test/ppx_deriving/test_intf.ml b/src_test/ppx_deriving/test_intf.ml index 49d203d..af05751 100644 --- a/src_test/ppx_deriving/test_intf.ml +++ b/src_test/ppx_deriving/test_intf.ml @@ -1 +1 @@ -type a = [%import: Stuff.a] +[%%import: type a = Stuff.a] diff --git a/src_test/ppx_deriving/test_intf.mli b/src_test/ppx_deriving/test_intf.mli index 49d203d..af05751 100644 --- a/src_test/ppx_deriving/test_intf.mli +++ b/src_test/ppx_deriving/test_intf.mli @@ -1 +1 @@ -type a = [%import: Stuff.a] +[%%import: type a = Stuff.a] diff --git a/src_test/ppx_deriving/test_ppx_import.ml b/src_test/ppx_deriving/test_ppx_import.ml index c06de65..682f170 100644 --- a/src_test/ppx_deriving/test_ppx_import.ml +++ b/src_test/ppx_deriving/test_ppx_import.ml @@ -1,18 +1,18 @@ open OUnit2 -type a = [%import: Stuff.a] -type b = [%import: Stuff.b] -type c = [%import: Stuff.c] -type d = [%import: Stuff.d] -type e = [%import: Stuff.e] -type f = [%import: Stuff.S.f] -type 'a g = [%import: 'a Stuff.g] -type 'b g' = [%import: 'b Stuff.g] -type h = [%import: Stuff.h] +[%%import: type a = Stuff.a] +[%%import: type b = Stuff.b] +[%%import: type c = Stuff.c] +[%%import: type d = Stuff.d] +[%%import: type e = Stuff.e] +[%%import: type f = Stuff.S.f] +[%%import: type 'a g = 'a Stuff.g] +[%%import: type 'b g' = 'b Stuff.g] +[%%import: type h = Stuff.h] module MI = Stuff.MI -type i = [%import: Stuff.i] +[%%import: type i = Stuff.i] module type S_rec = [%import: (module Stuff.S_rec)] @@ -27,7 +27,7 @@ let test_constr _ctxt = ignore (Succ Zero : h); ignore (I 1 : i) -type a' = [%import: Stuff.a] [@@deriving show] +[%%import: type a' = Stuff.a [@@deriving show]] let test_deriving _ctxt = assert_equal ~printer:(fun x -> x) "(Stuff.A2 \"a\")" (show_a' (A2 "a")) @@ -38,21 +38,21 @@ module Test_optional : S_optional = struct let f ?(opt = 0) () = ignore opt end -type longident = [%import: Longident.t] [@@deriving show] +[%%import: type longident = Longident.t [@@deriving show]] +[%%import: type package_type = - [%import: - (Parsetree.package_type - [@with - core_type := (Parsetree.core_type [@printer Pprintast.core_type]); - Asttypes.loc := - (Asttypes.loc [@polyprinter fun pp fmt x -> pp fmt x.Asttypes.txt]); - Longident.t := (Longident.t [@printer pp_longident])] )] -[@@deriving show] + (Parsetree.package_type + [@with + core_type := (Parsetree.core_type [@printer Pprintast.core_type]); + Asttypes.loc := + (Asttypes.loc [@polyprinter fun pp fmt x -> pp fmt x.Asttypes.txt]); + Longident.t := (Longident.t [@printer pp_longident])] ) +[@@deriving show]] module type Hashable = [%import: (module Hashtbl.HashedType)] -type self_t = [%import: Test_self_import.t] +[%%import: type self_t = Test_self_import.t] let test_self_import _ctxt = let v : self_t = `OptionA in diff --git a/src_test/ppx_deriving/test_self_import.ml b/src_test/ppx_deriving/test_self_import.ml index 88ec450..3f03f3f 100644 --- a/src_test/ppx_deriving/test_self_import.ml +++ b/src_test/ppx_deriving/test_self_import.ml @@ -1,4 +1,4 @@ -type t = [%import: Test_self_import.t] +[%%import: type t = Test_self_import.t] module type S = [%import: (module Test_self_import.S)] diff --git a/src_test/ppx_deriving_sexp/test_ppx_deriving_sexp.ml b/src_test/ppx_deriving_sexp/test_ppx_deriving_sexp.ml index b7decf9..d563f7d 100644 --- a/src_test/ppx_deriving_sexp/test_ppx_deriving_sexp.ml +++ b/src_test/ppx_deriving_sexp/test_ppx_deriving_sexp.ml @@ -1,4 +1,4 @@ -type sorts = [%import: Sorts.family] [@@deriving sexp] +[%%import: type sorts = Sorts.family [@@deriving sexp]] let main () = let test = Sorts.InType in From 546d799dbfb265f197ad3b2a5dfb11a2acac1031 Mon Sep 17 00:00:00 2001 From: tatchi Date: Thu, 14 Apr 2022 22:58:35 +0200 Subject: [PATCH 2/5] add changes entry --- CHANGES.md | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 4005fd9..b058076 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,19 @@ +Unreleased +----- + * **BREAKING:** Rewrite `ppx_import` as a context free rule. It changes the syntax of the type declaration from: + + ```ocaml + type loc = [%import: Location.t];; + ``` + + to: + + ```ocaml + [%%import : type loc = Location.t] + (* or *) + type%import loc = Location.t + ``` + 1.10.0 ------ From e51599245f9ce89d7682fdd4268ac7229c7b18bc Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Tue, 30 Aug 2022 11:25:13 +0200 Subject: [PATCH 3/5] cover alternate syntaxes in tests --- src_test/ppx_deriving/test_ppx_import.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src_test/ppx_deriving/test_ppx_import.ml b/src_test/ppx_deriving/test_ppx_import.ml index 682f170..42363b7 100644 --- a/src_test/ppx_deriving/test_ppx_import.ml +++ b/src_test/ppx_deriving/test_ppx_import.ml @@ -1,7 +1,7 @@ open OUnit2 -[%%import: type a = Stuff.a] -[%%import: type b = Stuff.b] +[%%import type a = Stuff.a] +type%import b = Stuff.b [%%import: type c = Stuff.c] [%%import: type d = Stuff.d] [%%import: type e = Stuff.e] From 19b230e68527f2f2984dd3580095f4ac82d0c306 Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Tue, 30 Aug 2022 11:41:01 +0200 Subject: [PATCH 4/5] add support for type%import t = a and t2 = b --- src/ppx_import.ml | 20 ++++++++++---------- src_test/ppx_deriving/test_ppx_import.ml | 3 +-- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/src/ppx_import.ml b/src/ppx_import.ml index ed5d224..08ee60a 100644 --- a/src/ppx_import.ml +++ b/src/ppx_import.ml @@ -501,19 +501,19 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) = | _ -> Location.raise_errorf ~loc "Imported module is indirectly defined" ) -let type_declaration_expand ~ctxt rec_flag type_decl = +let type_declaration_expand ~ctxt rec_flag type_decls = 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 type_decl = type_declaration ~tool_name ~input_name type_decl in - Ppxlib.{pstr_desc = Pstr_type (rec_flag, [type_decl]); pstr_loc = loc} + let type_decls = type_decls |> List.map (type_declaration ~tool_name ~input_name) in + Ppxlib.{pstr_desc = Pstr_type (rec_flag, type_decls); pstr_loc = loc} -let type_declaration_expand_intf ~ctxt rec_flag type_decl = +let type_declaration_expand_intf ~ctxt rec_flag type_decls = 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 type_decl = type_declaration ~tool_name ~input_name type_decl in - Ppxlib.{psig_desc = Psig_type (rec_flag, [type_decl]); psig_loc = loc} + let type_decls = type_decls |> List.map (type_declaration ~tool_name ~input_name) in + Ppxlib.{psig_desc = Psig_type (rec_flag, type_decls); psig_loc = loc} let module_declaration_expand ~ctxt package_type = let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in @@ -523,15 +523,15 @@ let module_declaration_expand ~ctxt package_type = let type_declaration_extension = Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.structure_item Ppxlib.Ast_pattern.( - psig (psig_type __ (__ ^:: nil) ^:: nil) - ||| pstr (pstr_type __ (__ ^:: nil) ^:: nil)) + psig (psig_type __ __ ^:: nil) + ||| pstr (pstr_type __ __ ^:: nil)) type_declaration_expand let type_declaration_extension_intf = Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item Ppxlib.Ast_pattern.( - psig (psig_type __ (__ ^:: nil) ^:: nil) - ||| pstr (pstr_type __ (__ ^:: nil) ^:: nil)) + psig (psig_type __ __ ^:: nil) + ||| pstr (pstr_type __ __ ^:: nil)) type_declaration_expand_intf let module_declaration_extension = diff --git a/src_test/ppx_deriving/test_ppx_import.ml b/src_test/ppx_deriving/test_ppx_import.ml index 42363b7..b81386b 100644 --- a/src_test/ppx_deriving/test_ppx_import.ml +++ b/src_test/ppx_deriving/test_ppx_import.ml @@ -2,8 +2,7 @@ open OUnit2 [%%import type a = Stuff.a] type%import b = Stuff.b -[%%import: type c = Stuff.c] -[%%import: type d = Stuff.d] +type%import c = Stuff.c and d = Stuff.d [%%import: type e = Stuff.e] [%%import: type f = Stuff.S.f] [%%import: type 'a g = 'a Stuff.g] From 5994950bf582c9252611e9dcd68587c1e852424f Mon Sep 17 00:00:00 2001 From: Corentin Leruth Date: Sat, 3 Sep 2022 06:56:11 +0200 Subject: [PATCH 5/5] update readme --- README.md | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index d1f05a9..78b6248 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[%%import] +Import ========== _import_ is a syntax extension that allows to pull in types or signatures from other compiled interface files. @@ -35,7 +35,7 @@ Syntax For example: ``` ocaml -# type loc = [%import: Location.t];; +# type%import loc = Location.t;; type loc = Location.t = { loc_start : Lexing.position; loc_end : Lexing.position; loc_ghost : bool; } # module type Hashable = [%import: (module Hashtbl.HashedType)];; module type Hashable = sig type t val equal : t -> t -> bool val hash : t -> int end @@ -50,7 +50,7 @@ It's possible to combine _import_ and [_deriving_][deriving] to derive functions [deriving]: https://github.com/whitequark/ppx_deriving ``` ocaml -type longident = [%import: Longident.t] [@@deriving show] +type%import longident = Longident.t [@@deriving show] let () = print_endline (show_longident (Longident.parse "Foo.Bar.baz")) (* Longident.Ldot (Longident.Ldot (Longident.Lident ("Foo"), "Bar"), "baz") *) @@ -65,11 +65,11 @@ It is possible to syntactically replace a type with another while importing a de For example, this snippet imports a single type from Parsetree and specifies a custom pretty-printer for _deriving show_. ``` ocaml -type package_type = -[%import: Parsetree.package_type +type%import package_type = +Parsetree.package_type [@with core_type := Parsetree.core_type [@printer Pprintast.core_type]; Asttypes.loc := Asttypes.loc [@polyprinter fun pp fmt x -> pp fmt x.Asttypes.txt]; - Longident.t := Longident.t [@printer pp_longident]]] + Longident.t := Longident.t [@printer pp_longident]] [@@deriving show] ```