Add pval_modalities (#2706)

ocaml/parsing/ast_helper.ml

@@ -412,11 +412,12 @@ end
 
 module Val = struct
   let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
-        ?(prim = []) name typ =
+        ?(prim = []) ?(modalities=[]) name typ =
     {
      pval_name = name;
      pval_type = typ;
      pval_attributes = add_docs_attrs docs attrs;
+     pval_modalities = modalities;
      pval_loc = loc;
      pval_prim = prim;
     }

ocaml/parsing/ast_helper.mli

@@ -209,8 +209,8 @@ module Exp:
 (** Value declarations *)
 module Val:
   sig
-    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
-      ?prim:string list -> str -> core_type -> value_description
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?prim:string list ->
+      ?modalities:modality with_loc list -> str -> core_type -> value_description
   end
 
 (** Type declarations *)

ocaml/parsing/ast_iterator.ml

@@ -99,6 +99,9 @@ let iter_loc_txt sub f { loc; txt } =
   sub.location sub loc;
   f sub txt
 
+let iter_modalities sub modalities =
+  List.iter (iter_loc sub) modalities
+
 module T = struct
   (* Type expressions for the core language *)
 
@@ -222,9 +225,6 @@ module T = struct
     | Ptype_record l -> List.iter (sub.label_declaration sub) l
     | Ptype_open -> ()
 
-  let iter_modalities sub modalities =
-    List.iter (iter_loc sub) modalities
-
   let iter_constructor_argument sub {pca_type; pca_loc; pca_modalities} =
     sub.typ sub pca_type;
     sub.location sub pca_loc;
@@ -835,15 +835,11 @@ let default_iterator =
     type_exception = T.iter_type_exception;
     extension_constructor = T.iter_extension_constructor;
     value_description =
-      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
+      (fun this {pval_name; pval_type; pval_modalities; pval_prim = _; pval_loc;
                  pval_attributes} ->
-        let modes, ptyp_attributes =
-          Jane_syntax.Mode_expr.maybe_of_attrs pval_type.ptyp_attributes
-        in
-        Option.iter (this.modes this) modes;
-        let pval_type = {pval_type with ptyp_attributes} in
         iter_loc this pval_name;
         this.typ this pval_type;
+        iter_modalities this pval_modalities;
         this.location this pval_loc;
         this.attributes this pval_attributes;
       );
@@ -971,7 +967,7 @@ let default_iterator =
          this.typ this pld_type;
          this.location this pld_loc;
          this.attributes this pld_attributes;
-         T.iter_modalities this pld_modalities
+         iter_modalities this pld_modalities
       );
 
     cases = (fun this l -> List.iter (this.case this) l);

ocaml/parsing/ast_mapper.ml

@@ -106,6 +106,9 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
 let map_loc_txt sub f {loc; txt} =
   {loc = sub.location sub loc; txt = f sub txt}
 
+let map_modalities sub modalities =
+  List.map (map_loc sub) modalities
+
 let map_mode_and_attributes sub attrs =
   let open Jane_syntax.Mode_expr in
   let modes, attrs = maybe_of_attrs attrs in
@@ -263,9 +266,6 @@ module T = struct
     | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
     | Ptype_open -> Ptype_open
 
-  let map_modalities sub modalities =
-    List.map (map_loc sub) modalities
-
   let map_constructor_argument sub x =
     let pca_type = sub.typ sub x.pca_type in
     let pca_loc = sub.location sub x.pca_loc in
@@ -959,11 +959,12 @@ let default_mapper =
     type_exception = T.map_type_exception;
     extension_constructor = T.map_extension_constructor;
     value_description =
-      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+      (fun this {pval_name; pval_type; pval_modalities; pval_prim; pval_loc;
                  pval_attributes} ->
         Val.mk
           (map_loc this pval_name)
           (this.typ this pval_type)
+          ~modalities:(map_modalities this pval_modalities)
           ~attrs:(this.attributes this pval_attributes)
           ~loc:(this.location this pval_loc)
           ~prim:pval_prim
@@ -1088,7 +1089,7 @@ let default_mapper =
            (map_loc this pld_name)
            (this.typ this pld_type)
            ~mut:pld_mutable
-           ~modalities:(T.map_modalities this pld_modalities)
+           ~modalities:(map_modalities this pld_modalities)
            ~loc:(this.location this pld_loc)
            ~attrs:(this.attributes this pld_attributes)
       );

ocaml/parsing/parser.mly

@@ -3710,13 +3710,12 @@ value_description:
   id = mkrhs(val_ident)
   COLON
   ty = possibly_poly(core_type)
-  modes = optional_atat_mode_expr
+  modalities = optional_atat_modalities_expr
   attrs2 = post_item_attributes
     { let attrs = attrs1 @ attrs2 in
-      let ty = mktyp_with_modes modes ty in
       let loc = make_loc $sloc in
       let docs = symbol_docs $sloc in
-      Val.mk id ty ~attrs ~loc ~docs,
+      Val.mk id ty ~attrs ~modalities ~loc ~docs,
       ext }
 ;
 
@@ -3729,13 +3728,14 @@ primitive_declaration:
   id = mkrhs(val_ident)
   COLON
   ty = possibly_poly(core_type)
+  modalities = optional_atat_modalities_expr
   EQUAL
   prim = raw_string+
   attrs2 = post_item_attributes
     { let attrs = attrs1 @ attrs2 in
       let loc = make_loc $sloc in
       let docs = symbol_docs $sloc in
-      Val.mk id ty ~prim ~attrs ~loc ~docs,
+      Val.mk id ty ~prim ~attrs ~modalities ~loc ~docs,
       ext }
 ;
 

ocaml/parsing/parsetree.mli

@@ -470,6 +470,7 @@ and value_description =
     {
      pval_name: string loc;
      pval_type: core_type;
+     pval_modalities : modality loc list;
      pval_prim: string list;
      pval_attributes: attributes;  (** [... [\@\@id1] [\@\@id2]] *)
      pval_loc: Location.t;

ocaml/parsing/pprintast.ml

@@ -312,6 +312,10 @@ let optional_legacy_modes f m =
     legacy_modes f m;
     pp_print_space f ()
 
+let space_modality f {txt = Modality m; _} =
+  pp_print_string f " ";
+  pp_print_string f m
+
 let legacy_modality f m =
   let {txt; _} = (m : modality Location.loc) in
   let s =
@@ -331,13 +335,17 @@ let optional_legacy_modalities f m =
     legacy_modalities f m;
     pp_print_space f ()
 
+let maybe_atat_modalities f m =
+  match m with
+  | [] -> ()
+  | _ :: _ ->
+    pp_print_string f " @@";
+    pp_print_list space_modality f m
+
 let mode f m =
   let {txt; _} = (m : Jane_syntax.Mode_expr.Const.t :> _ Location.loc) in
   pp_print_string f txt
 
-let modes f m =
-  pp_print_list ~pp_sep:(fun f () -> pp f " ") mode f m.txt
-
 let maybe_modes_of_type c =
   let m, cattrs = Jane_syntax.Mode_expr.maybe_of_attrs c.ptyp_attributes in
   m, { c with ptyp_attributes = cattrs }
@@ -348,12 +356,6 @@ let maybe_modes_type pty ctxt f c =
   | Some m -> pp f "%a %a" legacy_modes m (pty ctxt) c
   | None -> pty ctxt f c
 
-let maybe_type_atat_modes pty ctxt f c =
-  let m, c = maybe_modes_of_type c in
-  match m with
-  | Some m -> pp f "%a@ @@@@@ %a" (pty ctxt) c modes m
-  | None -> pty ctxt f c
-
 let modalities_type pty ctxt f pca =
   match pca.pca_modalities with
   | [] -> pty ctxt f pca.pca_type
@@ -1093,7 +1095,8 @@ and floating_attribute ctxt f a =
 and value_description ctxt f x =
   (* note: value_description has an attribute field,
            but they're already printed by the callers this method *)
-  pp f "@[<hov2>%a%a@]" (maybe_type_atat_modes core_type ctxt) x.pval_type
+  pp f "@[<hov2>%a%a%a@]" (core_type ctxt) x.pval_type
+    maybe_atat_modalities x.pval_modalities
     (fun f x ->
        if x.pval_prim <> []
        then pp f "@ =@ %a" (list constant_string) x.pval_prim

ocaml/parsing/printast.ml

@@ -390,6 +390,7 @@ and value_description i ppf x =
        x.pval_name fmt_location x.pval_loc;
   attributes i ppf x.pval_attributes;
   core_type (i+1) ppf x.pval_type;
+  modalities (i+1) ppf x.pval_modalities;
   list (i+1) string ppf x.pval_prim
 
 and type_parameter i ppf (x, _variance) = core_type i ppf x

ocaml/testsuite/tests/parsetree/modes_ast_mapper.ml

@@ -21,6 +21,8 @@ let test mapper s =
   ignore (mapper.Ast_mapper.structure mapper p);
   Format.printf "------------------------------\n"
 
+(* CR zqian: add [modalities] to mapper so the following [bar hello] can be
+   printed *)
 let () =
   test mapper "let f (local_ x) = x";
   test mapper "let unique_ f (local_ x) = x";

ocaml/testsuite/tests/parsetree/modes_ast_mapper.reference

@@ -8,6 +8,5 @@ local [File "_none_", line 1, characters 29-30]
 local [File "_none_", line 1, characters 4-10]
 local [File "_none_", line 1, characters 4-10]
 ------------------------------
-bar hello [File "_none_", line 1, characters 49-58]
 foo [File "_none_", line 1]
 ------------------------------

ocaml/testsuite/tests/parsing/extensions.compilers.reference

@@ -283,13 +283,15 @@
                   Ptyp_constr "t" (extensions.ml[24,573+19]..[24,573+20])
                   []
                 []
+                []
             signature_item (extensions.ml[24,573+22]..[24,573+31])
               Psig_value
               value_description "y" (extensions.ml[24,573+26]..[24,573+27]) (extensions.ml[24,573+22]..[24,573+31])
                 core_type (extensions.ml[24,573+30]..[24,573+31])
                   Ptyp_constr "t" (extensions.ml[24,573+30]..[24,573+31])
                   []
                 []
+                []
           ]
         expression (extensions.ml[25,606+4]..[25,606+23])
           Pexp_extension "foo"

ocaml/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference

@@ -684,6 +684,7 @@
             []
           core_type (shortcut_ext_attr.ml[85,1728+23]..[85,1728+24])
             Ptyp_any
+          []
           [
             ""
           ]
@@ -787,6 +788,7 @@
                     Ptyp_constr "t" (shortcut_ext_attr.ml[98,1965+20]..[98,1965+21])
                     []
                   []
+                  []
             ]
           signature_item (shortcut_ext_attr.ml[99,1987+2]..[99,1987+31]) ghost
             Psig_extension "foo"
@@ -799,6 +801,7 @@
                   core_type (shortcut_ext_attr.ml[99,1987+25]..[99,1987+26])
                     Ptyp_constr "t" (shortcut_ext_attr.ml[99,1987+25]..[99,1987+26])
                     []
+                  []
                   [
                     ""
                   ]

ocaml/testsuite/tests/tool-ocamlc-stop-after/stop_after_parsing_intf.compilers.reference

@@ -6,5 +6,6 @@
         Ptyp_constr "Module_that_does_not_exists.type_that_does_not_exists" (stop_after_parsing_intf.mli[12,306+8]..[12,306+61])
         []
       []
+      []
 ]
 

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

@@ -390,8 +390,18 @@ module type S = sig
   val x : string -> string @ local @@ foo bar
 end
 [%%expect{|
-Line 2, characters 38-45:
+Line 2, characters 38-41:
 2 |   val x : string -> string @ local @@ foo bar
-                                          ^^^^^^^
+                                          ^^^
+Error: Modalities on value descriptions are not supported yet.
+|}]
+
+module type S = sig
+  external x : string -> string @ local @@ foo bar = "%hello"
+end
+[%%expect{|
+Line 2, characters 43-46:
+2 |   external x : string -> string @ local @@ foo bar = "%hello"
+                                               ^^^
 Error: Modalities on value descriptions are not supported yet.
 |}]

ocaml/typing/typedecl.ml

@@ -2861,10 +2861,11 @@ let error_if_containing_unexpected_jkind prim env cty ty =
 
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
-  match Jane_syntax.Mode_expr.maybe_of_attrs valdecl.pval_type.ptyp_attributes with
-  | Some modes, _ -> raise (Error(modes.loc, Modalities_on_value_description))
-  | None, _ ->
   let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  begin match valdecl.pval_modalities with
+  | [] -> ()
+  | m :: _ -> raise (Error(m.loc, Modalities_on_value_description))
+  end;
   (* CR layouts v5: relax this to check for representability. *)
   begin match Ctype.constrain_type_jkind env cty.ctyp_type
                 (Jkind.value ~why:Structure_element) with