support @recursive_modalities

ocaml/parsing/builtin_attributes.ml

@@ -112,6 +112,7 @@ let builtin_attrs =
   ; "layout_poly"
   ; "no_mutable_implied_modalities"
   ; "or_null_reexport"
+  ; "recursive_modalities"
   ]
 
 let drop_ocaml_attr_prefix s =

ocaml/testsuite/tests/typing-modes/val_modalities.ml

@@ -549,3 +549,66 @@ module type S' =
 
 (* CR zqian: add tests of recursive modules & include w/ modalties, once
    modules can have modes. *)
+
+module type S = sig
+  val bar : 'a -> 'a
+  module M : sig
+    val foo : 'a -> 'a
+  end
+end
+[%%expect{|
+module type S =
+  sig val bar : 'a -> 'a module M : sig val foo : 'a -> 'a end end
+|}]
+
+module type S' = sig
+  include S @@ portable
+end
+[%%expect{|
+module type S' =
+  sig
+    val bar : 'a -> 'a @@ portable
+    module M : sig val foo : 'a -> 'a end
+  end
+|}]
+
+module type S' = sig
+  include [@recursive_modalities] S @@ portable
+end
+[%%expect{|
+module type S' =
+  sig
+    val bar : 'a -> 'a @@ portable
+    module M : sig val foo : 'a -> 'a @@ portable end
+  end
+|}]
+
+module type T = sig
+  val baz : 'a -> 'a
+  module M : S
+end
+[%%expect{|
+module type T = sig val baz : 'a -> 'a module M : S end
+|}]
+
+module type T' = sig
+  include T @@ portable
+end
+[%%expect{|
+module type T' = sig val baz : 'a -> 'a @@ portable module M : S end
+|}]
+
+module type T' = sig
+  include [@recursive_modalities] T @@ portable
+end
+[%%expect{|
+module type T' =
+  sig
+    val baz : 'a -> 'a @@ portable
+    module M :
+      sig
+        val bar : 'a -> 'a @@ portable
+        module M : sig val foo : 'a -> 'a @@ portable end
+      end
+  end
+|}]

ocaml/typing/typemod.ml

@@ -979,7 +979,7 @@ let map_ext fn exts =
   | [] -> []
   | d1 :: dl -> fn Text_first d1 :: List.map (fn Text_next) dl
 
-let apply_modalities_signature modalities sg =
+let rec apply_modalities_signature ~recursive env modalities sg =
   List.map (function
   | Sig_value (id, vd, vis) ->
       let val_modalities =
@@ -990,7 +990,26 @@ let apply_modalities_signature modalities sg =
       in
       let vd = {vd with val_modalities} in
       Sig_value (id, vd, vis)
-  | item -> item) sg
+  | Sig_module (id, pres, md, rec_, vis) when recursive ->
+      let md_type = apply_modalities_module_type env modalities md.md_type in
+      let md = {md with md_type} in
+      Sig_module (id, pres, md, rec_, vis)
+  | item -> item
+  ) sg
+
+and apply_modalities_module_type env modalities = function
+  | Mty_ident p ->
+      let mtd = Env.find_modtype p env in
+      begin match mtd.mtd_type with
+      | None -> Mty_ident p
+      | Some mty -> apply_modalities_module_type env modalities mty
+      end
+  | Mty_strengthen (mty, p, alias) ->
+      Mty_strengthen (apply_modalities_module_type env modalities mty, p, alias)
+  | Mty_signature sg ->
+      let sg = apply_modalities_signature ~recursive:true env modalities sg in
+      Mty_signature sg
+  | (Mty_functor _ | Mty_alias _) as mty -> mty
 
 (* Auxiliary for translating recursively-defined module types.
    Return a module type that approximates the shape of the given module
@@ -1167,7 +1186,11 @@ and approx_sig env ssg =
       | Psig_open sod ->
           let _, env = type_open_descr env sod in
           approx_sig env srem
-      | Psig_include ({pincl_loc=loc; pincl_mod=mod_; pincl_kind=kind; _}, moda) ->
+      | Psig_include ({pincl_loc=loc; pincl_mod=mod_; pincl_kind=kind;
+            pincl_attributes=attrs}, moda) ->
+          let recursive =
+            Builtin_attributes.has_attribute "recursive_modalities" attrs
+          in
           begin match kind with
           | Functor ->
               Jane_syntax_parsing.assert_extension_enabled ~loc Include_functor ();
@@ -1179,7 +1202,9 @@ and approx_sig env ssg =
               let modalities =
                 Typemode.transl_modalities ~maturity:Alpha Immutable [] moda
               in
-              let sg = apply_modalities_signature modalities sg in
+              let sg =
+                apply_modalities_signature ~recursive env modalities sg
+              in
               let sg, newenv = Env.enter_signature ~scope sg env in
               sg @ approx_sig newenv srem
           end
@@ -1676,6 +1701,10 @@ and transl_signature env sg =
   let names = Signature_names.create () in
 
   let transl_include ~loc env sig_acc sincl modalities =
+    let recursive =
+      Builtin_attributes.has_attribute "recursive_modalities"
+        sincl.pincl_attributes
+    in
     let smty = sincl.pincl_mod in
     let tmty =
       Builtin_attributes.warning_scope sincl.pincl_attributes
@@ -1697,7 +1726,7 @@ and transl_signature env sg =
     let modalities =
       Typemode.transl_modalities ~maturity:Alpha Immutable [] modalities
     in
-    let sg = apply_modalities_signature modalities sg in
+    let sg = apply_modalities_signature ~recursive env modalities sg in
     let sg, newenv = Env.enter_signature ~scope sg env in
     Signature_group.iter
       (Signature_names.check_sig_item names loc)