Add optional package_type to pexp_pack (#2234)

ocaml-ppx · Jan 29, 2023 · 650bae5 · 650bae5
1 parent 01c583f
commit 650bae5
Show file tree

Hide file tree

Showing 14 changed files with 88 additions and 98 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -26,6 +26,7 @@
 - Preserve position of comments around type alias (#2239, @EmileTrotignon)
 - Preserve position of comments around constructor record (#2237, @EmileTrotignon)
 - Preserve position of comments around external declaration strings (#2238, @EmileTrotignon, @gpetiot)
+- Preserve position of comments around module pack expressions (#2234, @EmileTrotignon, @gpetiot)
 
 ### Changes
 

diff --git a/lib/Ast.ml b/lib/Ast.ml
@@ -955,9 +955,7 @@ end = struct
       | _ -> assert false )
     | Exp ctx -> (
       match ctx.pexp_desc with
-      | Pexp_constraint (_, ({ptyp_desc= Ptyp_package (_, it1N); _} as ty))
-        ->
-          assert (typ == ty || List.exists it1N ~f:snd_f)
+      | Pexp_pack (_, Some (_, it1N)) -> assert (List.exists it1N ~f:snd_f)
       | Pexp_constraint (_, t1)
        |Pexp_coerce (_, None, t1)
        |Pexp_poly (_, Some t1)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
@@ -705,15 +705,6 @@ and type_constr_and_body c xbody =
     , sub_exp ~ctx exp )
   in
   match xbody.ast.pexp_desc with
-  | Pexp_constraint
-      ( ({pexp_desc= Pexp_pack _; pexp_attributes= []; _} as exp)
-      , ({ptyp_desc= Ptyp_package _; ptyp_attributes= []; _} as typ) ) ->
-      Cmts.relocate c.cmts ~src:body.pexp_loc ~before:exp.pexp_loc
-        ~after:exp.pexp_loc ;
-      fmt_cstr_and_xbody typ exp
-  | Pexp_constraint
-      ({pexp_desc= Pexp_pack _; _}, {ptyp_desc= Ptyp_package _; _}) ->
-      (None, xbody)
   | Pexp_constraint (exp, typ) ->
       Cmts.relocate c.cmts ~src:body.pexp_loc ~before:exp.pexp_loc
         ~after:exp.pexp_loc ;
@@ -1990,29 +1981,6 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
         (parens || not (List.is_empty pexp_attributes))
         c.conf
         (fmt_constant c ?epi const $ fmt_atrs)
-  | Pexp_constraint
-      ( {pexp_desc= Pexp_pack me; pexp_attributes= []; pexp_loc; _}
-      , {ptyp_desc= Ptyp_package (id, cnstrs); ptyp_attributes= []; _} ) ->
-      let opn_paren =
-        match c.conf.fmt_opts.indicate_multiline_delimiters.v with
-        | `No | `Closing_on_separate_line -> str "("
-        | `Space -> fits_breaks "(" "( "
-      in
-      let cls_paren = closing_paren c ~offset:(-2) in
-      hovbox 0
-        (compose_module
-           (fmt_module_expr c (sub_mod ~ctx me))
-           ~f:(fun m ->
-             Params.parens_if parens c.conf
-               (hvbox 2
-                  (Cmts.fmt c pexp_loc
-                     ( hovbox 0
-                         ( opn_paren $ str "module"
-                         $ fmt_extension_suffix c ext
-                         $ char ' ' $ m $ fmt "@ : " $ fmt_longident_loc c id
-                         )
-                     $ fmt_package_type c ctx cnstrs
-                     $ cls_paren $ fmt_atrs ) ) ) ) )
   | Pexp_constraint (e, t) ->
       hvbox 2
         ( wrap_fits_breaks ~space:false c.conf "(" ")"
@@ -2330,12 +2298,28 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
                | `Closing_on_separate_line -> "@;<1000 -2>)" ) ) )
   | Pexp_match (e0, cs) -> fmt_match c ~parens ?ext ctx xexp cs e0 "match"
   | Pexp_try (e0, cs) -> fmt_match c ~parens ?ext ctx xexp cs e0 "try"
-  | Pexp_pack me ->
+  | Pexp_pack (me, pt) ->
       let fmt_mod m =
         Params.parens_if parens c.conf
-          ( Params.Exp.wrap c.conf ~parens:true
-              (str "module" $ fmt_extension_suffix c ext $ char ' ' $ m)
-          $ fmt_atrs )
+          ( match pt with
+          | Some (id, cnstrs) ->
+              let opn_paren =
+                match c.conf.fmt_opts.indicate_multiline_delimiters.v with
+                | `No | `Closing_on_separate_line -> str "("
+                | `Space -> fits_breaks "(" "( "
+              in
+              let cls_paren = closing_paren c ~offset:(-2) in
+              hvbox 2
+                ( hovbox 0
+                    ( opn_paren $ str "module"
+                    $ fmt_extension_suffix c ext
+                    $ char ' ' $ m $ fmt "@ : " $ fmt_longident_loc c id )
+                $ fmt_package_type c ctx cnstrs
+                $ cls_paren $ fmt_atrs )
+          | None ->
+              Params.Exp.wrap c.conf ~parens:true
+                (str "module" $ fmt_extension_suffix c ext $ char ' ' $ m)
+              $ fmt_atrs )
       in
       hvbox 0
         (compose_module (fmt_module_expr c (sub_mod ~ctx me)) ~f:fmt_mod)
@@ -2440,14 +2424,7 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
                             | Pexp_function _ | Pexp_letexception _
                             | Pexp_open _ | Pexp_assert _ | Pexp_lazy _
                             | Pexp_pack _ | Pexp_fun _ | Pexp_beginend _
-                            | Pexp_letopen _
-                            | Pexp_constraint
-                                ( { pexp_desc= Pexp_pack _
-                                  ; pexp_attributes= []
-                                  ; _ }
-                                , { ptyp_desc= Ptyp_package _
-                                  ; ptyp_attributes= []
-                                  ; _ } ) )
+                            | Pexp_letopen _ )
                         ; pexp_attributes= []
                         ; _ } as e1 )
                     , _ )

diff --git a/lib/Sugar.ml b/lib/Sugar.ml
@@ -308,20 +308,7 @@ module Let_binding = struct
           in
           let ctx = Exp body in
           match (body.pexp_desc, pat.ppat_desc) with
-          | ( Pexp_constraint
-                ( ({pexp_desc= Pexp_pack _; pexp_attributes= []; _} as exp)
-                , ({ptyp_desc= Ptyp_package _; ptyp_attributes= []; _} as typ)
-                )
-            , _ )
-            when Source.type_constraint_is_first typ exp.pexp_loc ->
-              Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc
-                ~after:exp.pexp_loc ;
-              (xpat, `Other (xargs, sub_typ ~ctx typ), sub_exp ~ctx exp)
-          | ( Pexp_constraint
-                ({pexp_desc= Pexp_pack _; _}, {ptyp_desc= Ptyp_package _; _})
-            , _ )
-           |Pexp_constraint _, Ppat_constraint _ ->
-              (xpat, `None xargs, xbody)
+          | Pexp_constraint _, Ppat_constraint _ -> (xpat, `None xargs, xbody)
           | Pexp_constraint (exp, typ), _
             when Source.type_constraint_is_first typ exp.pexp_loc ->
               Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc

diff --git a/test/passing/tests/comments.ml b/test/passing/tests/comments.ml
@@ -255,6 +255,10 @@ let kk = ((module A : T) (* foo *))
 
 let kk = ((* foo *) (module A : T) (* foo *))
 
+let kk = (* before exp *) ((* before exp_pack *) (module (* before A *) A (* after A *)) (* after exp_pack *)) (* after exp *)
+
+let kk = (* before exp *) ((* before exp_pack *) (module (* before A *) A (* after A *) : (* before S *) S (* after S *)) (* after exp_pack *)) (* after exp *)
+
 let _ = assert (foo (bar + baz <= quux))
 (* this comment should stay attached to the preceding item *)
 

diff --git a/test/passing/tests/comments.ml.ref b/test/passing/tests/comments.ml.ref
@@ -328,11 +328,25 @@ module A (* A *) () =
 
 let kk = (* foo *) (module A : T)
 
-let kk = (* foo *) (module A : T)
+let kk = ((* foo *) (module A : T))
+
+let kk = ((module A : T) (* foo *))
+
+let kk = ((* foo *) (module A : T) (* foo *))
 
-let kk = (module A : T) (* foo *)
+let kk =
+  (* before exp *)
+  ((* before exp_pack *)
+   (module (* before A *) A (* after A *))
+   (* after exp_pack *) )
+(* after exp *)
 
-let kk = (* foo *) (module A : T) (* foo *)
+let kk =
+  (* before exp *)
+  ((* before exp_pack *)
+   (module (* before A *) A (* after A *) : (* before S *) S (* after S *))
+   (* after exp_pack *) )
+(* after exp *)
 
 let _ = assert (foo (bar + baz <= quux))
 (* this comment should stay attached to the preceding item *)

diff --git a/vendor/diff-parsers-ext-parsewyc.patch b/vendor/diff-parsers-ext-parsewyc.patch
@@ -574,11 +574,11 @@
        { Pexp_apply($1, $2) }
    | expr_comma_list %prec below_COMMA
 @@@@
- ;
-
- simple_expr:
-   | LPAREN seq_expr RPAREN
-       { reloc_exp ~loc:$sloc $2 }
+   | LPAREN e = seq_expr RPAREN
+       { match e.pexp_desc with
+         | Pexp_pack _ ->
+             mkexp ~loc:$sloc (Pexp_parens e)
+         | _ -> reloc_exp ~loc:$sloc e }
 -  | LPAREN seq_expr error
 -      { unclosed "(" $loc($1) ")" $loc($3) }
    | LPAREN seq_expr type_constraint RPAREN
@@ -605,9 +605,9 @@
    | NEW ext_attributes mkrhs(class_longident)
        { Pexp_new($3), $2 }
    | LPAREN MODULE ext_attributes module_expr RPAREN
-       { Pexp_pack $4, $3 }
-   | LPAREN MODULE ext_attributes module_expr COLON package_core_type RPAREN
-       { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
+       { Pexp_pack ($4, None), $3 }
+   | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+       { Pexp_pack ($4, Some $6), $3 }
 -  | LPAREN MODULE ext_attributes module_expr COLON error
 -      { unclosed "(" $loc($1) ")" $loc($6) }
    | OBJECT ext_attributes class_structure END
@@ -688,10 +688,10 @@
 -    LBRACKET expr_semi_list error
 -      { unclosed "[" $loc($3) "]" $loc($5) }
    | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
-     package_core_type RPAREN
+     package_type RPAREN
        { let modexp =
            mkexp_attrs ~loc:($startpos($3), $endpos)
-             (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
+             (Pexp_pack ($6, Some $8)) $5 in
          Pexp_open(od, modexp) }
 -  | mod_longident DOT
 -    LPAREN MODULE ext_attributes module_expr COLON error

diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml
@@ -152,7 +152,7 @@ module Exp = struct
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
   let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
   let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
-  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
+  let pack ?loc ?attrs a b = mk ?loc ?attrs (Pexp_pack (a, b))
   let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
   let letopen ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letopen (a, b))
   let letop ?loc ?attrs let_ ands body =

diff --git a/vendor/parser-extended/ast_helper.mli b/vendor/parser-extended/ast_helper.mli
@@ -181,7 +181,8 @@ module Exp:
               -> expression
     val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
     val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
-    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
+    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> package_type option
+              -> expression
     val open_: ?loc:loc -> ?attrs:attrs -> lid -> expression -> expression
     val letopen: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression
                -> expression

diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml
@@ -543,7 +543,10 @@ module E = struct
     | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
     | Pexp_newtype (s, e) ->
         newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
-    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+    | Pexp_pack (me, pt) ->
+        pack ~loc ~attrs
+          (sub.module_expr sub me)
+          (map_opt (map_package_type sub) pt)
     | Pexp_open (o, e) -> open_ ~loc ~attrs (map_loc sub o) (sub.expr sub e)
     | Pexp_letopen (o, e) ->
         letopen ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e)

diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly
@@ -2201,8 +2201,11 @@ expr:
 ;
 
 simple_expr:
-  | LPAREN seq_expr RPAREN
-      { reloc_exp ~loc:$sloc $2 }
+  | LPAREN e = seq_expr RPAREN
+      { match e.pexp_desc with
+        | Pexp_pack _ ->
+            mkexp ~loc:$sloc (Pexp_parens e)
+        | _ -> reloc_exp ~loc:$sloc e }
   | LPAREN seq_expr error
       { unclosed "(" $loc($1) ")" $loc($3) }
   | LPAREN seq_expr type_constraint RPAREN
@@ -2229,9 +2232,9 @@ simple_expr:
   | NEW ext_attributes mkrhs(class_longident)
       { Pexp_new($3), $2 }
   | LPAREN MODULE ext_attributes module_expr RPAREN
-      { Pexp_pack $4, $3 }
-  | LPAREN MODULE ext_attributes module_expr COLON package_core_type RPAREN
-      { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
+      { Pexp_pack ($4, None), $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+      { Pexp_pack ($4, Some $6), $3 }
   | LPAREN MODULE ext_attributes module_expr COLON error
       { unclosed "(" $loc($1) ")" $loc($6) }
   | OBJECT ext_attributes class_structure END
@@ -2317,10 +2320,10 @@ simple_expr:
     LBRACKET expr_semi_list error
       { unclosed "[" $loc($3) "]" $loc($5) }
   | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
-    package_core_type RPAREN
+    package_type RPAREN
       { let modexp =
           mkexp_attrs ~loc:($startpos($3), $endpos)
-            (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
+            (Pexp_pack ($6, Some $8)) $5 in
         Pexp_open(od, modexp) }
   | mod_longident DOT
     LPAREN MODULE ext_attributes module_expr COLON error

diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli
@@ -423,11 +423,9 @@ and expression_desc =
            values). *)
   | Pexp_object of class_structure  (** [object ... end] *)
   | Pexp_newtype of string loc * expression  (** [fun (type t) -> E] *)
-  | Pexp_pack of module_expr
-      (** [(module ME)].
-
-           [(module ME : S)] is represented as
-           [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *)
+  | Pexp_pack of module_expr * package_type option
+      (** - [(module M)] is represented as [Pexp_pack(M, None)]
+          - [(module M : S)] is represented as [Pexp_pack(M, Some S)] *)
   | Pexp_open of Longident.t loc * expression  (** [M.(E)] *)
   | Pexp_letopen of open_declaration * expression
       (** - [let open M in E]

diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml
@@ -453,9 +453,10 @@ and expression i ppf x =
   | Pexp_newtype (s, e) ->
       line i ppf "Pexp_newtype %a\n" fmt_string_loc s;
       expression i ppf e
-  | Pexp_pack me ->
+  | Pexp_pack (me, pt) ->
       line i ppf "Pexp_pack\n";
-      module_expr i ppf me
+      module_expr i ppf me;
+      option i package_type ppf pt
   | Pexp_open (lid, e) ->
       line i ppf "Pexp_open\n";
       longident_loc i ppf lid;

diff --git a/vendor/parser-recovery/lib/parser.mly b/vendor/parser-recovery/lib/parser.mly
@@ -2147,8 +2147,11 @@ expr [@recover.expr Annot.Exp.mk ()]:
 ;
 
 simple_expr:
-  | LPAREN seq_expr RPAREN
-      { reloc_exp ~loc:$sloc $2 }
+  | LPAREN e = seq_expr RPAREN
+      { match e.pexp_desc with
+        | Pexp_pack _ ->
+            mkexp ~loc:$sloc (Pexp_parens e)
+        | _ -> reloc_exp ~loc:$sloc e }
   | LPAREN seq_expr type_constraint RPAREN
       { mkexp_constraint ~loc:$sloc $2 $3 }
   | indexop_expr(DOT, seq_expr, { None })
@@ -2169,9 +2172,9 @@ simple_expr:
   | NEW ext_attributes mkrhs(class_longident)
       { Pexp_new($3), $2 }
   | LPAREN MODULE ext_attributes module_expr RPAREN
-      { Pexp_pack $4, $3 }
-  | LPAREN MODULE ext_attributes module_expr COLON package_core_type RPAREN
-      { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
+      { Pexp_pack ($4, None), $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+      { Pexp_pack ($4, Some $6), $3 }
   | OBJECT ext_attributes class_structure END
       { Pexp_object $3, $2 }
 ;
@@ -2233,10 +2236,10 @@ simple_expr:
   | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
       { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) }
   | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
-    package_core_type RPAREN
+    package_type RPAREN
       { let modexp =
           mkexp_attrs ~loc:($startpos($3), $endpos)
-            (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
+            (Pexp_pack ($6, Some $8)) $5 in
         Pexp_open(od, modexp) }
 ;
 labeled_simple_expr: