Implement basic modal modules.

Signed-off-by: Thomas Del Vecchio <[email protected]>

lib/Fmt_ast.ml

@@ -24,6 +24,12 @@ type c =
   ; cmts: Cmts.t
   ; fmt_code: Fmt_odoc.fmt_code }
 
+type modals = No_modals | Modes of modes | Modalities of modalities
+
+let is_empty_modals = function
+  | No_modals | Modes [] | Modalities [] -> true
+  | Modes (_ :: _) | Modalities (_ :: _) -> false
+
 module Cmts = struct
   include Cmts
 
@@ -719,7 +725,7 @@ and fmt_payload c ctx pld =
       fmt_if (not (List.is_empty mex)) "@ " $ fmt_structure c ctx mex
   | PSig ({psg_modalities; _} as mty) ->
       fmt ":"
-      $ fmt_modalities ~pro:(fmt " ") c psg_modalities
+      $ fmt_modals ~pro:(fmt " ") c ~ats:`Two (Modalities psg_modalities)
       $ fmt "@ "
       $ fmt_signature c ctx {mty with psg_modalities= []}
   | PTyp typ -> fmt ":@ " $ fmt_core_type c (sub_typ ~ctx typ)
@@ -773,24 +779,22 @@ and type_constr_and_body c xbody =
       , sub_exp ~ctx:exp_ctx exp )
   | _ -> (None, xbody)
 
-and fmt_modalities ?(pro = fmt "@ ") c modalities =
+and fmt_modals ?(pro = fmt "@ ") c ~ats modals =
+  let fmt_ats =
+    match ats with `Zero -> str "" | `One -> str "@ " | `Two -> str "@@ "
+  in
+  let fmt_modal {txt; loc} = Cmts.fmt c loc (str txt) in
+  let fmt_mode {txt= Mode mode; loc} = fmt_modal {txt= mode; loc} in
   let fmt_modality {txt= Modality modality; loc} =
-    Cmts.fmt c loc (str modality)
+    fmt_modal {txt= modality; loc}
   in
-  if List.is_empty modalities then noop
-  else pro $ fmt "@@@@ " $ hvbox 0 (list modalities "@ " fmt_modality)
-
-and fmt_modes ~ats c modes =
-  let fmt_mode {txt= Mode mode; loc} = Cmts.fmt c loc (str mode) in
-  if List.is_empty modes then noop
-  else
-    let fmt_ats =
-      match ats with
-      | `Zero -> fmt "@ "
-      | `One -> fmt "@ @@ "
-      | `Two -> fmt "@ @@@@ "
-    in
-    fmt_ats $ hvbox 0 (list modes "@ " fmt_mode)
+  let fmt_modals =
+    match modals with
+    | No_modals -> noop
+    | Modes modes -> list modes "@ " fmt_mode
+    | Modalities modalities -> list modalities "@ " fmt_modality
+  in
+  fmt_if_k (not (is_empty_modals modals)) (pro $ fmt_ats $ hvbox 0 fmt_modals)
 
 and fmt_type_var ~have_tick c (s : ty_var) =
   let {txt= name_opt; loc= name_loc}, jkind_opt = s in
@@ -831,7 +835,7 @@ and fmt_jkind c ~ctx {txt= jkd; loc} =
             | Default | Abbreviation _ | Kind_of _ -> assert false )
           | _ -> false
         in
-        let mode_fmt = hvbox 0 (fmt_modes ~ats:`Zero c modes) in
+        let mode_fmt = hvbox 0 (fmt_modals ~ats:`Zero c (Modes modes)) in
         let fmt =
           fmt_jkind c ~ctx:inner_ctx jkind
           $ fmt "@ mod" $ Cmts.fmt_within c loc $ mode_fmt
@@ -915,7 +919,7 @@ and fmt_arrow_param ~return c ctx
     | None -> core_type
     | Some f -> hovbox 2 (f $ core_type)
   in
-  let modes = fmt_modes c mI ~ats:`One in
+  let modes = fmt_modals c ~ats:`One (Modes mI) in
   hvbox 0 (Cmts.fmt_before c locI $ arg $ modes)
 
 (** Format [Ptyp_arrow]. [indent] can be used to override the indentation
@@ -1476,7 +1480,8 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
       hvbox 2
         (Params.parens_if parens c.conf
            ( fmt_pattern c (sub_pat ~ctx pat)
-           $ fmt_typ $ fmt_modes c ~ats modes ) )
+           $ fmt_typ
+           $ fmt_modals c ~ats (Modes modes) ) )
   | Ppat_type lid -> fmt_longident_loc c ~pre:"#" lid
   | Ppat_lazy pat ->
       cbox 2
@@ -2534,7 +2539,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
                  ( fmt_expression c (sub_exp ~ctx e)
                  $ fmt "@ : "
                  $ fmt_core_type c (sub_typ ~ctx t)
-                 $ fmt_modes c ~ats:`Two modes )
+                 $ fmt_modals c ~ats:`Two (Modes modes) )
              $ fmt_atrs ) )
   | Pexp_construct ({txt= Lident (("()" | "[]") as txt); loc}, None) ->
       let opn = char txt.[0] and cls = char txt.[1] in
@@ -2735,8 +2740,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
               (parens || not (List.is_empty pexp_attributes))
               c.conf
               ( hvbox 2
-                  (fmt_module c ctx keyword ~eqty:":" name args (Some xbody)
-                     xmty
+                  (fmt_module c ctx keyword ~eqty:":" name No_modals args
+                     (Some xbody) xmty
                      ~attrs:(Ast_helper.Attr.ext_attrs ?ext ())
                      ~epi:(str "in") ~can_sparse ~rec_flag:false )
               $ fmt "@;<1000 0>"
@@ -3681,7 +3686,7 @@ and fmt_value_description ?ext c ctx vd =
                  ( c.conf.fmt_opts.ocp_indent_compat.v
                  && is_arrow_or_poly pval_type ) )
             ~pro_space:true (sub_typ ~ctx pval_type)
-        $ fmt_modalities c pval_modalities
+        $ fmt_modals c ~ats:`Two (Modalities pval_modalities)
         $ fmt_if (not (List.is_empty pval_prim)) "@ = "
         $ hvbox_if (List.length pval_prim > 1) 0
           @@ list pval_prim "@;" fmt_val_prim )
@@ -3885,7 +3890,8 @@ and fmt_label_declaration c ctx ?(last = false) decl =
                                 $ fmt_if field_loose " " $ fmt ":" )
                             $ fmt "@ "
                             $ fmt_core_type c (sub_typ ~ctx pld_type) )
-                        $ fmt_modalities c pld_modalities )
+                        $ fmt_modals c ~ats:`Two (Modalities pld_modalities)
+                        )
                     $ fmt_semicolon )
                 $ cmt_after_type )
             $ fmt_attributes c ~pre:(Break (1, 1)) atrs )
@@ -3947,7 +3953,8 @@ and fmt_constructor_arguments ?vars c ctx ~pre = function
                      Cmts.fmt c pca_loc
                      @@ hvbox 0
                           ( fmt_core_type_gf c ctx pca_type
-                          $ fmt_modalities c pca_modalities ) ) )
+                          $ fmt_modals c ~ats:`Two (Modalities pca_modalities)
+                          ) ) )
       in
       pre $ vars $ cargs
   | Pcstr_record (loc, lds) ->
@@ -4111,7 +4118,7 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) =
       ; pro=
           Some
             ( before $ str "sig"
-            $ fmt_modalities c psg_modalities
+            $ fmt_modals c ~ats:`Two (Modalities psg_modalities)
             $ fmt_if empty " " )
       ; psp= fmt_if (not empty) "@;<1000 2>"
       ; bdy=
@@ -4234,7 +4241,7 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) =
       ; epi= Some epi1 }
 
 and fmt_signature c ctx sg =
-  fmt_modalities c sg.psg_modalities
+  fmt_modals c ~ats:`Two (Modalities sg.psg_modalities)
   $ fmt_signature_item_list c ctx sg.psg_items
 
 and fmt_signature_item_list c ctx itms =
@@ -4321,7 +4328,9 @@ and fmt_signature_item c ?ext {ast= si; _} =
                 $ bdy )
             $ esp $ fmt_opt epi
             $ fmt_item_attributes c ~pre:(Break (1, 0)) atrs
-            $ fmt_modalities ~pro:(fmt_or has_attrs "@ " " ") c modalities )
+            $ fmt_modals
+                ~pro:(fmt_or has_attrs "@ " " ")
+                c ~ats:`Two (Modalities modalities) )
         $ doc_after )
   | Psig_modtype mtd -> fmt_module_type_declaration c ctx mtd
   | Psig_modtypesubst mtd -> fmt_module_type_declaration ~eqty:":=" c ctx mtd
@@ -4419,7 +4428,7 @@ and fmt_class_exprs ?ext c ctx cls =
            @@ Cmts.fmt c cl.pci_loc (doc_before $ class_exprs $ doc_after) )
 
 and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=")
-    name xargs xbody xmty ~attrs ~rec_flag =
+    name modals xargs xbody xmty ~attrs ~rec_flag =
   let ext = attrs.attrs_extension in
   let blk_t =
     Option.value_map xmty ~default:empty ~f:(fun xmty ->
@@ -4475,7 +4484,11 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=")
     str keyword
     $ fmt_extension_suffix c ext
     $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before
-    $ fmt_if rec_flag " rec" $ str " " $ fmt_str_loc_opt c name
+    $ fmt_if rec_flag " rec" $ str " "
+    $ wrap_if
+        (not (is_empty_modals modals))
+        "(" ")"
+        (fmt_str_loc_opt c name $ fmt_modals c ~ats:`One modals)
   in
   let compact =
     Poly.(c.conf.fmt_opts.let_module.v = `Compact) || not can_sparse
@@ -4513,7 +4526,14 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=")
 and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} =
   protect c (Md pmd)
   @@
-  let {pmd_name; pmd_args; pmd_type; pmd_ext_attrs= attrs; pmd_loc} = pmd in
+  let { pmd_name
+      ; pmd_modalities
+      ; pmd_args
+      ; pmd_type
+      ; pmd_ext_attrs= attrs
+      ; pmd_loc } =
+    pmd
+  in
   update_config_maybe_disabled_attrs c pmd_loc attrs
   @@ fun c ->
   let ctx = Md pmd in
@@ -4523,8 +4543,9 @@ and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} =
     match xmty.ast.pmty_desc with Pmty_alias _ -> None | _ -> Some ":"
   in
   Cmts.fmt c pmd_loc
-    (fmt_module ~rec_:rec_flag c ctx keyword pmd_name pmd_args None ?eqty
-       (Some xmty) ~rec_flag:(rec_flag && first) ~attrs )
+    (fmt_module ~rec_:rec_flag c ctx keyword pmd_name
+       (Modalities pmd_modalities) pmd_args None ?eqty (Some xmty)
+       ~rec_flag:(rec_flag && first) ~attrs )
 
 and fmt_module_substitution c ctx pms =
   let {pms_name; pms_manifest; pms_ext_attrs= attrs; pms_loc} = pms in
@@ -4539,15 +4560,16 @@ and fmt_module_substitution c ctx pms =
   in
   let pms_name = {pms_name with txt= Some pms_name.txt} in
   Cmts.fmt c pms_loc
-    (fmt_module c ctx "module" ~eqty:":=" pms_name [] None (Some xmty) ~attrs
-       ~rec_flag:false )
+    (fmt_module c ctx "module" ~eqty:":=" pms_name No_modals [] None
+       (Some xmty) ~attrs ~rec_flag:false )
 
 and fmt_module_type_declaration ?eqty c ctx pmtd =
   let {pmtd_name; pmtd_type; pmtd_ext_attrs= attrs; pmtd_loc} = pmtd in
   update_config_maybe_disabled_attrs c pmtd_loc attrs
   @@ fun c ->
   let pmtd_name = {pmtd_name with txt= Some pmtd_name.txt} in
-  fmt_module ?eqty c ctx "module type" pmtd_name [] None ~rec_flag:false
+  fmt_module ?eqty c ctx "module type" pmtd_name No_modals [] None
+    ~rec_flag:false
     (Option.map pmtd_type ~f:(sub_mty ~ctx))
     ~attrs
 
@@ -4611,14 +4633,15 @@ and fmt_with_constraint c ctx ~pre = function
       let m1 = {m1 with txt= Some (str_longident m1.txt)} in
       let m2 = Some (sub_mty ~ctx m2) in
       str pre $ break 1 2
-      $ fmt_module c ctx "module type" m1 [] None ~rec_flag:false m2
+      $ fmt_module c ctx "module type" m1 No_modals [] None ~rec_flag:false
+          m2
           ~attrs:(Ast_helper.Attr.ext_attrs ())
   | Pwith_modtypesubst (m1, m2) ->
       let m1 = {m1 with txt= Some (str_longident m1.txt)} in
       let m2 = Some (sub_mty ~ctx m2) in
       str pre $ break 1 2
-      $ fmt_module c ctx ~eqty:":=" "module type" m1 [] None ~rec_flag:false
-          m2
+      $ fmt_module c ctx ~eqty:":=" "module type" m1 No_modals [] None
+          ~rec_flag:false m2
           ~attrs:(Ast_helper.Attr.ext_attrs ())
 
 and fmt_mod_apply c ctx loc attrs ~parens ~dock_struct me_f arg =
@@ -5124,8 +5147,8 @@ and fmt_value_binding c ~rec_flag ?(punned_in_output = false) ?ext ?in_ ?epi
                                       ( fmt_pattern c lb_pat
                                       $ fmt_if_k
                                           (has_args || not has_cstr)
-                                          (fmt_modes c ~ats:`One lb_modes) )
-                                  )
+                                          (fmt_modals c ~ats:`One
+                                             (Modes lb_modes) ) ) )
                               $ fmt_if_k has_args
                                   ( fmt "@ "
                                   $ wrap_fun_decl_args c
@@ -5134,7 +5157,7 @@ and fmt_value_binding c ~rec_flag ?(punned_in_output = false) ?ext ?in_ ?epi
                           $ fmt_cstr
                           $ fmt_if_k
                               ((not has_args) && has_cstr)
-                              (fmt_modes c ~ats:`Two lb_modes) )
+                              (fmt_modals c ~ats:`Two (Modes lb_modes)) )
                       $ fmt_if_k (not punned_in_output)
                           (fmt_or_k c.conf.fmt_opts.ocp_indent_compat.v
                              (fits_breaks " =" ~hint:(1000, 0) "=")
@@ -5167,7 +5190,7 @@ and fmt_module_binding c ~rec_flag ~first {ast= pmb; _} =
   in
   Cmts.fmt c pmb.pmb_loc
     (fmt_module ~rec_:rec_flag c ctx keyword ~rec_flag:(rec_flag && first)
-       ~eqty:":" pmb_name pmb.pmb_args (Some xbody) xmty ~attrs )
+       ~eqty:":" pmb_name No_modals pmb.pmb_args (Some xbody) xmty ~attrs )
 
 let fmt_toplevel_directive c ~semisemi dir =
   let fmt_dir_arg = function
@@ -5279,12 +5302,12 @@ let fmt_file (type a) ~ctx ~fmt_code ~debug (fragment : a Extended_ast.t)
   let c = {source; cmts; conf; debug; fmt_code} in
   match (fragment, itms) with
   | Signature, {psg_items= []; psg_modalities; _} ->
-      fmt_modalities c psg_modalities
+      fmt_modals c ~ats:`Two (Modalities psg_modalities)
       $ Cmts.fmt_after ~pro:noop c Location.none
   | Structure, [] | Use_file, [] -> Cmts.fmt_after ~pro:noop c Location.none
   | Structure, l -> Chunk.split_and_fmt Structure c ctx l
   | Signature, {psg_modalities; psg_items= l; _} ->
-      fmt_modalities ~pro:noop c psg_modalities
+      fmt_modals ~pro:noop c ~ats:`Two (Modalities psg_modalities)
       $ fmt_if (not (List.is_empty psg_modalities)) "\n@;<1000 0>"
       $ Chunk.split_and_fmt Signature c ctx l
   | Use_file, l -> Chunk.split_and_fmt Use_file c ctx l

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

@@ -0,0 +1,21 @@
+@@ portable
+
+type t
+
+val portable : t
+val nonportable : t @@ nonportable
+
+module T : sig
+  val portable : t
+  val portable : t @@ nonportable
+end
+
+module T : sig @@ nonportable
+  val portable : t
+  val portable : t @@ nonportable
+end
+
+module (T @ nonportable) : sig @@ portable
+  val portable : t
+  val nonportable : t @@ nonportable
+end

test/passing/tests/module_modes.mli.ref

@@ -0,0 +1,25 @@
+@@ portable
+
+type t
+
+val portable : t
+
+val nonportable : t @@ nonportable
+
+module T : sig
+  val portable : t
+
+  val portable : t @@ nonportable
+end
+
+module T : sig @@ nonportable
+  val portable : t
+
+  val portable : t @@ nonportable
+end
+
+module (T @ nonportable) : sig @@ portable
+  val portable : t
+
+  val nonportable : t @@ nonportable
+end

vendor/parser-extended/ast_helper.ml

@@ -390,9 +390,10 @@ end
 
 module Md = struct
   let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ())
-        ?(docs = empty_docs) ?(text = []) name args typ =
+        ?(docs = empty_docs) ?(text = []) name modalities args typ =
     {
      pmd_name = name;
+     pmd_modalities = modalities;
      pmd_args = args;
      pmd_type = typ;
      pmd_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs);

vendor/parser-extended/ast_mapper.ml

@@ -890,9 +890,10 @@ let default_mapper =
     binding_op = E.map_binding_op;
 
     module_declaration =
-      (fun this {pmd_name; pmd_args; pmd_type; pmd_ext_attrs; pmd_loc} ->
+      (fun this {pmd_name; pmd_modalities; pmd_args; pmd_type; pmd_ext_attrs; pmd_loc} ->
          Md.mk
            (map_loc this pmd_name)
+           (this.modalities this pmd_modalities)
            (List.map (map_functor_param this) pmd_args)
            (this.module_type this pmd_type)
            ~attrs:(this.ext_attrs this pmd_ext_attrs)