feat: support type%foo extension sugar (#2790)

* feat: support `type%foo` extension sugar * add changelog entry
reasonml · Aug 20, 2024 · e79fbb3 · e79fbb3
1 parent c998144
commit e79fbb3
Show file tree

Hide file tree

Showing 7 changed files with 103 additions and 18 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -26,6 +26,8 @@
   (@anmonteiro, [#2784](https://github.com/reasonml/reason/pull/2784))
 - Add support for module type substitutions
   (@anmonteiro, [#2785](https://github.com/reasonml/reason/pull/2785))
+- Support `type%foo` extension sugar syntax (@anmonteiro,
+  [#2790](https://github.com/reasonml/reason/pull/2790))
 
 ## 3.12.0
 

diff --git a/src/reason-parser/reason_parser.mly b/src/reason-parser/reason_parser.mly
@@ -1704,9 +1704,20 @@ structure_item:
           $3
       }
     | type_declarations
-      { let (nonrec_flag, tyl) = $1 in mkstr(Pstr_type (nonrec_flag, tyl)) }
+      {
+        let (nonrec_flag, tyl, loc, extension) = $1 in
+        wrap_str_ext
+          ~loc
+          (mkstr(Pstr_type (nonrec_flag, tyl)))
+          extension
+      }
     | str_type_extension
-      { mkstr(Pstr_typext $1) }
+      { let typext, loc, extension = $1 in
+        wrap_str_ext
+          ~loc
+          (mkstr(Pstr_typext typext))
+          extension
+      }
     | str_exception_declaration
       { mkstr(Pstr_exception (Ast_helper.Te.mk_exception ~loc:$1.pext_loc $1)) }
     | item_attributes opt_LET_MODULE_ident module_binding_body
@@ -1933,11 +1944,21 @@ signature_item:
         $3
     }
   | type_declarations
-    { let (nonrec_flag, tyl) = $1 in Psig_type (nonrec_flag, tyl) }
+    { let (nonrec_flag, tyl, loc, extension) = $1 in
+      wrap_sig_ext
+        ~loc
+        (Psig_type (nonrec_flag, tyl))
+        extension
+    }
    | type_subst_declarations
     { Psig_typesubst $1 }
   | sig_type_extension
-    { Psig_typext $1 }
+    { let (typext, loc, extension) = $1 in
+      wrap_sig_ext
+        ~loc
+        (Psig_typext typext)
+        extension
+     }
   | sig_exception_declaration
     { Psig_exception $1 }
   | item_attributes opt_LET_MODULE_ident module_declaration
@@ -4041,7 +4062,14 @@ type_declarations:
     let loc = mklocation $startpos($2) endpos in
     let ty = Ast_helper.Type.mk ident ~params:params ~cstrs:constraints
              ~kind ~priv ?manifest ~attrs:$1 ~loc in
-    ($3, ty :: and_types)
+    ($3, ty :: and_types, loc, None)
+  }
+  | item_attributes TYPE item_extension_sugar nonrec_flag type_declaration_details
+  { let (ident, params, constraints, kind, priv, manifest), endpos, and_types = $5 in
+    let loc = mklocation $startpos($2) endpos in
+    let ty = Ast_helper.Type.mk ident ~params:params ~cstrs:constraints
+             ~kind ~priv ?manifest ~attrs:$1 ~loc in
+    ($4, ty :: and_types, loc, Some $3)
   }
 ;
 
@@ -4296,29 +4324,61 @@ record_declaration:
 
 str_type_extension:
   attrs = item_attributes
-  TYPE flag = nonrec_flag
+  TYPE
+  flag = nonrec_flag
     ident = as_loc(itype_longident)
     params = type_variables_with_variance
   PLUSEQ priv = embedded(private_flag)
   constructors =
     attributed_ext_constructors(either(extension_constructor_declaration, extension_constructor_rebind))
   { if flag <> Recursive then
       not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
-    Ast_helper.Te.mk ~params ~priv ~attrs ident constructors
+    let loc = mklocation $startpos($2) $endpos in
+    (Ast_helper.Te.mk ~loc ~params ~priv ~attrs ident constructors, loc, None)
+  }
+  | attrs = item_attributes
+  TYPE
+    extension = item_extension_sugar
+  flag = nonrec_flag
+    ident = as_loc(itype_longident)
+    params = type_variables_with_variance
+  PLUSEQ priv = embedded(private_flag)
+  constructors =
+    attributed_ext_constructors(either(extension_constructor_declaration, extension_constructor_rebind))
+  { if flag <> Recursive then
+      not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
+    let loc = mklocation $startpos($2) $endpos in
+    (Ast_helper.Te.mk ~loc ~params ~priv ~attrs ident constructors, loc, Some extension)
   }
 ;
 
 sig_type_extension:
   attrs = item_attributes
-  TYPE flag = nonrec_flag
+  TYPE
+  flag = nonrec_flag
+    ident = as_loc(itype_longident)
+    params = type_variables_with_variance
+  PLUSEQ priv = embedded(private_flag)
+  constructors =
+    attributed_ext_constructors(extension_constructor_declaration)
+  { if flag <> Recursive then
+      not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
+    let loc = mklocation $startpos($2) $endpos in
+    (Ast_helper.Te.mk ~params ~priv ~attrs ident constructors, loc, None)
+  }
+  | attrs = item_attributes
+  TYPE
+  extension = item_extension_sugar
+  flag = nonrec_flag
     ident = as_loc(itype_longident)
     params = type_variables_with_variance
   PLUSEQ priv = embedded(private_flag)
   constructors =
     attributed_ext_constructors(extension_constructor_declaration)
   { if flag <> Recursive then
       not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
-    Ast_helper.Te.mk ~params ~priv ~attrs ident constructors
+    let loc = mklocation $startpos($2) $endpos in
+    (Ast_helper.Te.mk ~params ~priv ~attrs ident constructors, loc, Some extension)
   }
 ;
 

diff --git a/src/reason-parser/reason_pprint_ast.ml b/src/reason-parser/reason_pprint_ast.ml
@@ -2905,8 +2905,8 @@ let createFormatter () =
           in
           source_map ~loc:pext_loc everything
 
-        (* shared by [Pstr_type,Psig_type]*)
-        method type_def_list ?(eq_symbol = "=") (rf, l) =
+        (* shared by [Pstr_type, Psig_type]*)
+        method type_def_list ?(eq_symbol = "=") ?extension rf l =
           (* As oposed to used in type substitution. *)
           let formatOneTypeDefStandard prepend td =
             let itm =
@@ -2935,7 +2935,9 @@ let createFormatter () =
           | hd :: tl ->
             let first =
               match rf with
-              | Recursive -> formatOneTypeDefStandard (atom "type") hd
+              | Recursive ->
+                let label = add_extension_sugar "type" extension in
+                formatOneTypeDefStandard (atom label) hd
               | Nonrecursive -> formatOneTypeDefStandard (atom "type nonrec") hd
             in
             (match tl with
@@ -8644,6 +8646,8 @@ let createFormatter () =
             | Psig_module pmd -> self#psig_module ~extension pmd
             | Psig_recmodule pmd -> self#psig_recmodule ~extension pmd
             | Psig_open od -> self#psig_open ~extension od
+            | Psig_type (rf, l) -> self#type_def_list ~extension rf l
+            | Psig_typext te -> self#type_extension ~extension te
             | _ -> self#payload "%%" extension (PSig [ item ]))
           | _ -> self#signature_item' item
 
@@ -8802,7 +8806,7 @@ let createFormatter () =
         method signature_item' x : Layout.t =
           let item : Layout.t =
             match x.psig_desc with
-            | Psig_type (rf, l) -> self#type_def_list (rf, l)
+            | Psig_type (rf, l) -> self#type_def_list rf l
             | Psig_value vd ->
               if vd.pval_prim != []
               then self#primitive_declaration vd
@@ -8907,8 +8911,7 @@ let createFormatter () =
                 ~loc:pms_loc
                 ~layout
                 ()
-            | Psig_typesubst l ->
-              self#type_def_list ~eq_symbol:":=" (Recursive, l)
+            | Psig_typesubst l -> self#type_def_list ~eq_symbol:":=" Recursive l
             | Psig_modtypesubst x -> self#modtype x ~delim:":="
           in
           source_map ~loc:x.psig_loc item
@@ -9207,6 +9210,8 @@ let createFormatter () =
                 self#attach_std_item_attrs binding.pmb_attributes module_binding
               | Pstr_recmodule decls -> self#recmodule ~extension decls
               | Pstr_open od -> self#pstr_open ~extension od
+              | Pstr_type (rf, l) -> self#type_def_list ~extension rf l
+              | Pstr_typext te -> self#type_extension ~extension te
               | _ ->
                 self#attach_std_item_attrs
                   attrs
@@ -9359,7 +9364,7 @@ let createFormatter () =
                 let jsxAttrNodes = List.map self#attribute jsxAttrs in
                 makeList ~sep:(Sep " ") (jsxAttrNodes @ [ layout ]))
             | Pstr_type (_, []) -> assert false
-            | Pstr_type (rf, l) -> self#type_def_list (rf, l)
+            | Pstr_type (rf, l) -> self#type_def_list rf l
             | Pstr_value (rf, l) -> self#bindings (rf, l)
             | Pstr_typext te -> self#type_extension te
             | Pstr_exception ed ->
@@ -9426,7 +9431,7 @@ let createFormatter () =
           in
           source_map ~loc:term.pstr_loc item
 
-        method type_extension te =
+        method type_extension ?extension te =
           let formatOneTypeExtStandard prepend ({ ptyext_path } as te) =
             let name = self#longident_loc ptyext_path in
             let item = self#formatOneTypeExt prepend name (atom "+=") te in
@@ -9443,7 +9448,8 @@ let createFormatter () =
               ~layout
               ()
           in
-          formatOneTypeExtStandard (atom "type") te
+          let label = add_extension_sugar "type" extension in
+          formatOneTypeExtStandard (atom label) te
 
         (* [allowUnguardedSequenceBodies] allows sequence expressions {} to the
            right of `=>` to not be guarded in `{}` braces. *)

diff --git a/test/general-syntax-rei.t/input.rei b/test/general-syntax-rei.t/input.rei
@@ -68,3 +68,6 @@ open%foo Bar;
 
 open! %foo Bar;
 
+type%foo t = int;
+
+type%x foo += Int;
diff --git a/test/general-syntax-rei.t/run.t b/test/general-syntax-rei.t/run.t
@@ -77,3 +77,8 @@ Format general interface syntax
   open%foo Bar;
   
   open! %foo Bar;
+  
+  type%foo t = int;
+  
+  type%x foo +=
+    | Int;
diff --git a/test/typeDeclarations.t/input.re b/test/typeDeclarations.t/input.re
@@ -60,3 +60,7 @@ type a = array({. "someStringKeyThatCausesLineToBreak": string });
 type b = {
   punned: [@with_attribute] punned
 };
+
+type%x foo = int;
+
+type%x foo += Int;
diff --git a/test/typeDeclarations.t/run.t b/test/typeDeclarations.t/run.t
@@ -128,3 +128,8 @@ Format type declarations
     });
 
   type b = {punned: [@with_attribute] punned};
+
+  type%x foo = int;
+
+  type%x foo +=
+    | Int;