Merge pull request #68 from tatchi/impl-new-ppx-syntax

implement new syntax for type declaration

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
 ------
 

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]
 ```
 

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,18 +501,38 @@ 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_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
-  type_declaration ~tool_name ~input_name type_decl
+  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_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_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
   let input_name = Ppxlib.Expansion_context.Extension.input_name ctxt in
   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)
+      ||| 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)
+      ||| pstr (pstr_type __ __ ^:: 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"

src_test/ppx_deriving/test_intf.ml

@@ -1 +1 @@
-type a = [%import: Stuff.a]
+[%%import: type a = Stuff.a]

src_test/ppx_deriving/test_intf.mli

@@ -1 +1 @@
-type a = [%import: Stuff.a]
+[%%import: type a = Stuff.a]

src_test/ppx_deriving/test_ppx_import.ml

@@ -1,18 +1,17 @@
 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]
+type%import b = Stuff.b
+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]
+[%%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 +26,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 +37,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

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)]
 

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