add missing parsing for modal modules

lib/Fmt_ast.ml

@@ -663,11 +663,11 @@ let extract_module_binding_constraints c ctx args modes body =
     match (args, xmodes) with
     | [], [] ->
         (* If there is no argument, then [xmodes_id] and [xmodes] are the
-           same thing, in which case we prefer [xmodes]. But we don't want to
-           reduce [module (M @ foo) @ bar = ...] to [module M @ foo bar =
+           same thing, in which case we prefer [xmodes_id]. But we don't want
+           to reduce [module (M @ foo) @ bar = ...] to [module M @ foo bar =
            ...] because that would be viewed as changed AST by the standard
            parser. *)
-        ([], modes)
+        (modes, [])
     | _ -> (modes, xmodes)
   in
   (xmodes_id, xmty, xmodes, xbody)

lib/Normalize_std_ast.ml

@@ -540,6 +540,36 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax =
             }
           else ca.pca_type ) }
   in
+  let module_binding (m : Ast_mapper.mapper) (mb : module_binding) =
+    (* Special cases: normalize the forms {[ module (M @ m) : S @ l = N ]} to
+       {[ module (M @ m l) : S = N ]} and {[ module M : S @ m = N ]} to {[
+       module (M @ m) : S = N ]} *)
+    let mb = Ast_mapper.default_mapper.module_binding m mb in
+    let pmod_desc =
+      match mb.pmb_expr.pmod_desc with
+      | Pmod_constraint
+          ( ( {pmod_desc= Pmod_constraint (expr, mty, outer_modes); _} as
+              inner_expr )
+          , None
+          , inner_modes ) ->
+          let inner_expr =
+            match mty with
+            | Some _ ->
+                {inner_expr with pmod_desc= Pmod_constraint (expr, mty, [])}
+            | None -> expr
+          in
+          Pmod_constraint (inner_expr, None, inner_modes @ outer_modes)
+      | Pmod_constraint (expr, (Some _ as mty), modes) ->
+          Pmod_constraint
+            ( { pmod_desc= Pmod_constraint (expr, mty, [])
+              ; pmod_loc= Location.none
+              ; pmod_attributes= [] }
+            , None
+            , modes )
+      | pmod_desc -> pmod_desc
+    in
+    {mb with pmb_expr= {mb.pmb_expr with pmod_desc}}
+  in
   { Ast_mapper.default_mapper with
     location
   ; attribute
@@ -558,7 +588,8 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax =
   ; modalities
   ; value_binding
   ; constructor_declaration
-  ; extension_constructor }
+  ; extension_constructor
+  ; module_binding }
 
 let ast fragment ~ignore_doc_comments ~erase_jane_syntax c =
   map fragment (make_mapper c ~ignore_doc_comments ~erase_jane_syntax)

test/passing/tests/module_modes.ml

@@ -71,10 +71,14 @@ let () =
   let module (* 38 *) M (* 39 *) @ (* 40 *) m (* 41 *) = (* 42 *) M (* 43 *) in
   ()
 
+(* test mode on ident *)
+
 module (M @ foo) = struct end
 
 module (M @ foo) : S = struct end
 
+(* No functor args: [bar] should move onto [M] *)
+
 module (M @ foo) @ bar = struct end
 
 module (M @ foo) : S @ bar = struct end
@@ -83,6 +87,8 @@ module (F @ foo) () = struct end
 
 module (F @ foo) () : S = struct end
 
+(* There are functor args: [bar] is not allowed to move *)
+
 module (F @ foo) () @ bar = struct end
 
 module (F @ foo) () : S @ bar = struct end
@@ -93,6 +99,35 @@ and (N @ foo) : S @ bar = struct end
 module rec (F @ foo) () : S @ bar = struct end
 and (G @ foo) () : S @ bar = struct end
 
+(* attributes *)
+
+module[@a] (M @ foo) = struct end
+
+module[@a] (M @ foo) : S = struct end
+
+module[@a] (M @ foo) @ bar = struct end
+
+module[@a] (M @ foo) : S @ bar = struct end
+
+module[@a] (F @ foo) () = struct end
+
+module[@a] (F @ foo) () : S = struct end
+
+module[@a] (F @ foo) () @ bar = struct end
+
+module[@a] (F @ foo) () : S @ bar = struct end
+
+module rec (M @ foo) = (struct end : S @ bar) [@a]
+and (N @ foo) = (struct end : S @ bar) [@a]
+
+module rec (F @ foo) () = (struct end : S @ bar) [@a]
+and (G @ foo) () = (struct end : S @ bar) [@a]
+
+module rec (M @ foo) : S @ bar = (struct end [@a])
+and (N @ foo) : S @ bar = (struct end [@a])
+
+module rec (F @ foo) () : S @ bar = (struct end [@a])
+and (G @ foo) () : S @ bar = (struct end [@a])
 
 let () =
   let module (M @ foo) = struct end in ()
@@ -117,3 +152,18 @@ let () =
 
 let () =
   let module (F @ foo) () : S @ bar = struct end in ()
+
+(* comments *)
+
+module rec (* 44 *) ( (* 45 *) F (* 46 *) @ (* 47 *) foo (* 48 *)) (* 49 *) () (* 50 *)
+  : (* 51 *) S (* 52 *) @ (* 53 *) bar (* 54 *) = (* 55 *) (struct (* 55 *) end (* 56 *)
+    [@a]) (* 57 *)
+and (* 58 *) (G (* 59 *) @ (* 60 *) foo (* 61 *)) (* 62 *) () (* 63 *)
+  : (* 64 *) S (* 65 *) @ (* 66 *) bar (* 67 *) = (* 68 *) (struct (* 69 *) end (* 70 *)
+    [@a]) (* 71 *)
+
+module (* 72 *) ( (* 73 *) M (* 74 *) @ (* 75 *) foo (* 76 *)) (* 77 *) @ (* 78 *) bar
+  (* 79 *) = (* 80 *) struct (* 81 *) end (* 82 *)
+
+module (* 83 *) ( (* 84 *) M (* 85 *) @ (* 86 *) foo (* 87 *)) (* 88 *)
+  : (* 89 *) S (* 90 *) @ (* 91 *) bar (* 92 *) = (* 93 *) struct (* 94 *) end (* 95 *)

test/passing/tests/module_modes.ml.js-ref

@@ -1,29 +1,29 @@
 (* bindings *)
 
-module M : sig
+module (M @ m) : sig
   type t
-end @ m =
+end =
   M
 
-module M : S @ m = M
-module M @ m = M
+module (M @ m) : S = M
+module (M @ m) = M
 
-module M : sig
+module (M @ m) : sig
   type t
-end @ m =
+end =
   M
 [@@a]
 
-module M : S @ m = M [@@a]
-module M @ m = M [@@a]
+module (M @ m) : S = M [@@a]
+module (M @ m) = M [@@a]
 
-module [@a] M : sig
+module [@a] (M @ m) : sig
   type t
-end @ m =
+end =
   M
 
-module [@a] M : S @ m = M
-module [@a] M @ m = M
+module [@a] (M @ m) : S = M
+module [@a] (M @ m) = M
 
 (* expressions *)
 
@@ -48,27 +48,23 @@ let () =
 
 (* test comment preservation *)
 
-module M : (* 02 *) sig
+module (M @ (* 05 *) m (* 06 *)) : (* 02 *) sig
   (* 03 *)
   type t
-end (* 04 *) @ (* 05 *) m (* 06 *) =
+end (* 04 *) =
   (* 01 *)
 
   (* 07 *)
   M
 (* 08 *)
 
-module M : (* 10 *) S (* 11 *) @ (* 12 *) m (* 13 *) =
+module (M @ (* 12 *) m (* 13 *)) : (* 10 *) S (* 11 *) =
   (* 09 *)
   (* 14 *)
   M
 (* 15 *)
 
-module M @ (* 17 *) m (* 18 *) =
-  (* 16 *)
-  (* 19 *)
-  M
-(* 20 *)
+module (M (* 16 *) @ (* 17 *) m (* 18 *)) = (* 19 *) M (* 20 *)
 
 let () =
   let module (* 21 *) M : (* 23 *) sig
@@ -106,28 +102,59 @@ let () =
   ()
 ;;
 
-module M @ foo = struct end
-module M : S @ foo = struct end
-module (M @ foo) @ bar = struct end
-module (M @ foo) : S @ bar = struct end
+(* test mode on ident *)
+
+module (M @ foo) = struct end
+module (M @ foo) : S = struct end
+
+(* No functor args: [bar] should move onto [M] *)
+
+module (M @ bar foo) = struct end
+module (M @ bar foo) : S = struct end
 module (F @ foo) () = struct end
 module (F @ foo) () : S = struct end
+
+(* There are functor args: [bar] is not allowed to move *)
+
 module (F @ foo) () @ bar = struct end
 module (F @ foo) () : S @ bar = struct end
 
-module rec (M @ foo) : S @ bar = struct end
-and (N @ foo) : S @ bar = struct end
+module rec (M @ bar foo) : S = struct end
+and (N @ bar foo) : S = struct end
 
 module rec (F @ foo) () : S @ bar = struct end
 and (G @ foo) () : S @ bar = struct end
 
+(* attributes *)
+
+module [@a] (M @ foo) = struct end
+module [@a] (M @ foo) : S = struct end
+module [@a] (M @ bar foo) = struct end
+module [@a] (M @ bar foo) : S = struct end
+module [@a] (F @ foo) () = struct end
+module [@a] (F @ foo) () : S = struct end
+module [@a] (F @ foo) () @ bar = struct end
+module [@a] (F @ foo) () : S @ bar = struct end
+
+module rec (M @ bar foo) = (struct end : S) [@a]
+and (N @ bar foo) = (struct end : S) [@a]
+
+module rec (F @ foo) () = (struct end : S @ bar) [@a]
+and (G @ foo) () = (struct end : S @ bar) [@a]
+
+module rec (M @ bar foo) : S = struct end [@a]
+and (N @ bar foo) : S = struct end [@a]
+
+module rec (F @ foo) () : S @ bar = struct end [@a]
+and (G @ foo) () : S @ bar = struct end [@a]
+
 let () =
-  let module M @ foo = struct end in
+  let module (M @ foo) = struct end in
   ()
 ;;
 
 let () =
-  let module M : S @ foo = struct end in
+  let module (M @ foo) : S = struct end in
   ()
 ;;
 
@@ -160,3 +187,61 @@ let () =
   let module (F @ foo) () : S @ bar = struct end in
   ()
 ;;
+
+(* comments *)
+
+module rec ((* 44 *)
+            (* 45 *)
+  F
+  (* 46 *)
+  @ (* 47 *) foo (* 48 *))
+    (* 49 *)
+  () : (* 51 *) S (* 52 *) @ (* 53 *) bar (* 54 *) =
+(* 50 *)
+(* 55 *) struct
+  (* 55 *)
+end [@a]
+(* 56 *)
+(* 57 *)
+
+and ((* 58 *) G (* 59 *) @ (* 60 *) foo (* 61 *)) (* 62 *) () : (* 64 *) S (* 65 *)
+@ (* 66 *) bar (* 67 *) =
+(* 63 *)
+(* 68 *) struct
+  (* 69 *)
+end [@a]
+(* 70 *)
+(* 71 *)
+
+module ((* 72 *)
+        (* 73 *)
+  M
+  (* 74 *)
+  @ (* 77 *)
+    (* 78 *)
+    bar
+    (* 79 *)
+    (* 75 *)
+    foo
+    (* 76 *)) =
+(* 80 *)
+struct
+  (* 81 *)
+end
+(* 82 *)
+
+module ((* 83 *)
+        (* 84 *)
+  M
+  (* 85 *)
+  @ (* 91 *)
+    bar
+    (* 92 *)
+    (* 86 *)
+    foo
+    (* 87 *)) : (* 89 *) S (* 90 *) =
+(* 88 *)
+(* 93 *) struct
+  (* 94 *)
+end
+(* 95 *)