Preserve syntax of module unpack with type constraint ('((module X) :…

… (module Y))' vs '(module X : Y)') (#2136)
ocaml-ppx · Aug 23, 2022 · a3b5a90 · a3b5a90
1 parent 8b76ecd
commit a3b5a90
Show file tree

Hide file tree

Showing 18 changed files with 250 additions and 84 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -10,6 +10,7 @@
 
 - Indent 2 columns after `initializer` keyword (#2145, @gpetiot)
 - Preserve syntax of generative modules (`(struct end)` vs `()`) (#2135, #2146, @trefis, @gpetiot)
+- Preserve syntax of module unpack with type constraint (`((module X) : (module Y))` vs `(module X : Y)`) (#2136, @trefis, @gpetiot)
 
 ## 0.24.1 (2022-07-18)
 

diff --git a/lib/Ast.ml b/lib/Ast.ml
@@ -1090,6 +1090,8 @@ end = struct
       match ctx.ppat_desc with
       | Ppat_constraint (_, t1) -> assert (typ == t1)
       | Ppat_extension (_, PTyp t) -> assert (typ == t)
+      | Ppat_unpack (_, Some (_, l)) ->
+          assert (List.exists l ~f:(fun (_, t) -> typ == t))
       | _ -> assert false )
     | Exp ctx -> (
       match ctx.pexp_desc with
@@ -2002,10 +2004,6 @@ end = struct
         | Str {pstr_desc= Pstr_value _; _} )
       , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) ) ->
         false
-    | ( ( Exp {pexp_desc= Pexp_let _ | Pexp_letop _; _}
-        | Str {pstr_desc= Pstr_value _; _} )
-      , Ppat_constraint _ ) ->
-        true
     | _, Ppat_constraint _
      |_, Ppat_unpack _
      |( Pat

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
@@ -1067,9 +1067,6 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
                 ~after:lid1.loc ;
               let typ = sub_typ ~ctx:(Pat pat) t in
               Cmts.fmt c ppat_loc @@ fmt_record_field c ~typ lid1
-          | Ppat_constraint ({ppat_desc= Ppat_unpack _; ppat_loc; _}, _) ->
-              Cmts.fmt c ppat_loc
-              @@ fmt_record_field c ~rhs:(fmt_rhs ~ctx pat) lid1
           | Ppat_constraint (p, t) when List.is_empty ppat_attributes ->
               let typ = sub_typ ~ctx:(Pat pat) t
               and rhs = fmt_rhs ~ctx:(Pat pat) p in
@@ -1171,24 +1168,6 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
         $ fmt_or_k nested
             (fits_breaks (if parens then ")" else "") "")
             (fits_breaks (if parens then ")" else "") ~hint:(1, 2) ")") )
-  | Ppat_constraint
-      ( {ppat_desc= Ppat_unpack name; ppat_attributes= []; ppat_loc; _}
-      , ( { ptyp_desc= Ptyp_package (id, cnstrs)
-          ; ptyp_attributes= []
-          ; ptyp_loc= (* TODO: use ptyp_loc *) _
-          ; _ } as typ ) ) ->
-      let ctx = Typ typ in
-      hovbox 0
-        (Params.parens_if parens c.conf
-           (hvbox 1
-              (Cmts.fmt c typ.ptyp_loc
-                 ( hovbox 0
-                     ( Cmts.fmt c ppat_loc
-                         ( str "module"
-                         $ fmt_extension_suffix c ext
-                         $ char ' ' $ fmt_str_loc_opt c name )
-                     $ fmt "@ : " $ fmt_longident_loc c id )
-                 $ fmt_package_type c ctx cnstrs ) ) ) )
   | Ppat_constraint (pat, typ) ->
       hvbox 2
         (Params.parens_if parens c.conf
@@ -1205,11 +1184,21 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
            $ fmt_extension_suffix c ext
            $ fmt "@ "
            $ fmt_pattern c (sub_pat ~ctx pat) ) )
-  | Ppat_unpack name ->
-      wrap_fits_breaks_if ~space:false c.conf parens "(" ")"
+  | Ppat_unpack (name, pt) ->
+      let fmt_constraint_opt pt k =
+        match pt with
+        | Some (id, cnstrs) ->
+            hovbox 0
+              (Params.parens_if parens c.conf
+                 (hvbox 1
+                    ( hovbox 0 (k $ fmt "@ : " $ fmt_longident_loc c id)
+                    $ fmt_package_type c ctx cnstrs ) ) )
+        | None -> wrap_fits_breaks_if ~space:false c.conf parens "(" ")" k
+      in
+      fmt_constraint_opt pt
         ( str "module"
         $ fmt_extension_suffix c ext
-        $ fmt "@ " $ fmt_str_loc_opt c name )
+        $ char ' ' $ fmt_str_loc_opt c name )
   | Ppat_exception pat ->
       cbox 2
         (Params.parens_if parens c.conf
@@ -1220,11 +1209,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
   | Ppat_extension
       ( ext
       , PPat
-          ( ( { ppat_desc=
-                  ( Ppat_lazy _ | Ppat_unpack _ | Ppat_exception _
-                  | Ppat_constraint
-                      ( {ppat_desc= Ppat_unpack _; _}
-                      , {ptyp_desc= Ptyp_package _; _} ) )
+          ( ( { ppat_desc= Ppat_lazy _ | Ppat_unpack _ | Ppat_exception _
               ; ppat_loc
               ; ppat_attributes= []
               ; _ } as pat )

diff --git a/test/passing/tests/js_source.ml b/test/passing/tests/js_source.ml
@@ -4325,11 +4325,13 @@ module M' = M
 module B' = B
 
 class b : B.a = object
+ method a : 'a. 'a M.s -> 'a = fun (type a) (module X : M.S with type a = a) -> X.v
  method a : 'a. 'a M.s -> 'a = fun (type a) ((module X) : (module M.S with type
 a = a)) -> X.v
 end
 
 class b' : B.a = object
+ method a : 'a. 'a M'.s -> 'a = fun (type a) (module X : M'.S with type a = a) -> X.v
  method a : 'a. 'a M'.s -> 'a = fun (type a) ((module X) : (module M'.S with
 type a = a)) -> X.v
 end

diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err
@@ -1,7 +1,7 @@
 Warning: tests/js_source.ml:157 exceeds the margin
 Warning: tests/js_source.ml:3559 exceeds the margin
-Warning: tests/js_source.ml:9541 exceeds the margin
-Warning: tests/js_source.ml:9644 exceeds the margin
-Warning: tests/js_source.ml:9663 exceeds the margin
-Warning: tests/js_source.ml:9703 exceeds the margin
-Warning: tests/js_source.ml:9785 exceeds the margin
+Warning: tests/js_source.ml:9547 exceeds the margin
+Warning: tests/js_source.ml:9650 exceeds the margin
+Warning: tests/js_source.ml:9669 exceeds the margin
+Warning: tests/js_source.ml:9709 exceeds the margin
+Warning: tests/js_source.ml:9791 exceeds the margin
diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp
@@ -5050,11 +5050,17 @@ module B' = B
 class b : B.a =
   object
     method a : 'a. 'a M.s -> 'a = fun (type a) (module X : M.S with type a = a) -> X.v
+
+    method a : 'a. 'a M.s -> 'a =
+      fun (type a) ((module X) : (module M.S with type a = a)) -> X.v
   end
 
 class b' : B.a =
   object
     method a : 'a. 'a M'.s -> 'a = fun (type a) (module X : M'.S with type a = a) -> X.v
+
+    method a : 'a. 'a M'.s -> 'a =
+      fun (type a) ((module X) : (module M'.S with type a = a)) -> X.v
   end
 
 module type FOO = sig

diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref
@@ -5050,11 +5050,17 @@ module B' = B
 class b : B.a =
   object
     method a : 'a. 'a M.s -> 'a = fun (type a) (module X : M.S with type a = a) -> X.v
+
+    method a : 'a. 'a M.s -> 'a =
+      fun (type a) ((module X) : (module M.S with type a = a)) -> X.v
   end
 
 class b' : B.a =
   object
     method a : 'a. 'a M'.s -> 'a = fun (type a) (module X : M'.S with type a = a) -> X.v
+
+    method a : 'a. 'a M'.s -> 'a =
+      fun (type a) ((module X) : (module M'.S with type a = a)) -> X.v
   end
 
 module type FOO = sig

diff --git a/test/passing/tests/source.ml b/test/passing/tests/source.ml
@@ -4325,11 +4325,13 @@ module M' = M
 module B' = B
 
 class b : B.a = object
+ method a : 'a. 'a M.s -> 'a = fun (type a) (module X : M.S with type a = a) -> X.v
  method a : 'a. 'a M.s -> 'a = fun (type a) ((module X) : (module M.S with type
 a = a)) -> X.v
 end
 
 class b' : B.a = object
+ method a : 'a. 'a M'.s -> 'a = fun (type a) (module X : M'.S with type a = a) -> X.v
  method a : 'a. 'a M'.s -> 'a = fun (type a) ((module X) : (module M'.S with
 type a = a)) -> X.v
 end

diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref
@@ -4808,12 +4808,18 @@ class b : B.a =
   object
     method a : 'a. 'a M.s -> 'a =
       fun (type a) (module X : M.S with type a = a) -> X.v
+
+    method a : 'a. 'a M.s -> 'a =
+      fun (type a) ((module X) : (module M.S with type a = a)) -> X.v
   end
 
 class b' : B.a =
   object
     method a : 'a. 'a M'.s -> 'a =
       fun (type a) (module X : M'.S with type a = a) -> X.v
+
+    method a : 'a. 'a M'.s -> 'a =
+      fun (type a) ((module X) : (module M'.S with type a = a)) -> X.v
   end
 
 module type FOO = sig

diff --git a/vendor/diff-parsers-ext-parsewyc.patch b/vendor/diff-parsers-ext-parsewyc.patch
@@ -585,7 +585,7 @@
        { Pexp_new($3), $2 }
    | LPAREN MODULE ext_attributes module_expr RPAREN
        { Pexp_pack $4, $3 }
-   | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+   | LPAREN MODULE ext_attributes module_expr COLON package_core_type RPAREN
        { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
 -  | LPAREN MODULE ext_attributes module_expr COLON error
 -      { unclosed "(" $loc($1) ")" $loc($6) }
@@ -667,7 +667,7 @@
 -    LBRACKET expr_semi_list error
 -      { unclosed "[" $loc($3) "]" $loc($5) }
    | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
-     package_type RPAREN
+     package_core_type RPAREN
        { let modexp =
            mkexp_attrs ~loc:($startpos($3), $endpos)
              (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
@@ -758,7 +758,7 @@
 -      { unclosed "(" $loc($1) ")" $loc($5) }
 -  | LPAREN pattern COLON error
 -      { expecting $loc($4) "type" }
--  | LPAREN MODULE ext_attributes module_name COLON package_type
+-  | LPAREN MODULE ext_attributes module_name COLON package_core_type
 -    error
 -      { unclosed "(" $loc($1) ")" $loc($7) }
    | extension