Add modalities to With in the parsetree

Parse and represent optional modalities on `with` in jkind annotations. This
supports jkind annotations like:

    value mod portable many uncontended with 'a @@ uncontended with int

parsing/ast_helper.ml

@@ -142,7 +142,7 @@ module Typ = struct
         | Default as x -> x
         | Abbreviation _ as x -> x
         | Mod (jkind, modes) -> Mod (loop_jkind jkind, modes)
-        | With (jkind, typ) -> With (loop_jkind jkind, loop typ)
+        | With (jkind, typ, modalities) -> With (loop_jkind jkind, loop typ, modalities)
         | Kind_of typ -> Kind_of (loop typ)
         | Product jkinds -> Product (List.map loop_jkind jkinds)
       in

parsing/ast_iterator.ml

@@ -842,9 +842,10 @@ let default_iterator =
          | Mod (t, mode_list) ->
              this.jkind_annotation this t;
              this.modes this mode_list
-         | With (t, ty) ->
+         | With (t, ty, modalities) ->
              this.jkind_annotation this t;
-             this.typ this ty
+             this.typ this ty;
+             this.modalities this modalities
          | Kind_of ty -> this.typ this ty
          | Product ts -> List.iter (this.jkind_annotation this) ts);
 

parsing/ast_mapper.ml

@@ -946,8 +946,8 @@ let default_mapper =
         | Abbreviation (s : string) -> Abbreviation s
         | Mod (t, mode_list) ->
           Mod (this.jkind_annotation this t, this.modes this mode_list)
-        | With (t, ty) ->
-          With (this.jkind_annotation this t, this.typ this ty)
+        | With (t, ty, modalities) ->
+          With (this.jkind_annotation this t, this.typ this ty, this.modalities this modalities)
         | Kind_of ty -> Kind_of (this.typ this ty)
         | Product ts -> Product (List.map (this.jkind_annotation this) ts)
       in

parsing/depend.ml

@@ -139,9 +139,9 @@ and add_jkind bv (jkind : jkind_annotation) =
   | Default -> ()
   | Abbreviation _ -> ()
   | Mod (jkind, (_ : modes)) -> add_jkind bv jkind
-  | With (jkind, typ) ->
+  | With (jkind, typ, (_ : modalities)) ->
       add_jkind bv jkind;
-      add_type bv typ
+      add_type bv typ;
   | Kind_of typ ->
       add_type bv typ
   | Product jkinds ->

parsing/parser.mly

@@ -3964,9 +3964,8 @@ jkind_desc:
       in
       Mod ($1, modes)
     }
-  (* CR layouts v2.8: The types should be separated by AND, not WITH *)
-  | jkind_annotation WITH core_type {
-      With ($1, $3)
+  | jkind_annotation WITH core_type optional_atat_modalities_expr {
+      With ($1, $3, $4)
     }
   | ident {
       Abbreviation $1

parsing/parsetree.mli

@@ -1299,7 +1299,7 @@ and jkind_annotation_desc =
   (* CR layouts v2.8: [mod] can have only layouts on the left, not
      full kind annotations. We may want to narrow this type some. *)
   | Mod of jkind_annotation * modes
-  | With of jkind_annotation * core_type
+  | With of jkind_annotation * core_type * modalities
   | Kind_of of core_type
   | Product of jkind_annotation list
 

parsing/pprintast.ml

@@ -463,11 +463,13 @@ and jkind_annotation ?(nested = false) ctxt f k = match k.pjkind_desc with
           (pp_print_list ~pp_sep:pp_print_space mode) modes
       ) f (t, modes)
     end
-  | With (t, ty) ->
-    Misc.pp_parens_if nested (fun f (t, ty) ->
-      pp f "%a with %a" (jkind_annotation ~nested:true ctxt) t (core_type ctxt)
-        ty
-    ) f (t, ty)
+  | With (t, ty, modalities) ->
+    Misc.pp_parens_if nested (fun f (t, ty, modalities) ->
+      pp f "%a with %a%a"
+        (jkind_annotation ~nested:true ctxt) t
+        (core_type ctxt) ty
+        optional_space_atat_modalities modalities;
+    ) f (t, ty, modalities)
   | Kind_of ty -> pp f "kind_of_ %a" (core_type ctxt) ty
   | Product ts ->
     Misc.pp_parens_if nested (fun f ts ->

parsing/printast.ml

@@ -506,10 +506,11 @@ and jkind_annotation i ppf (jkind : jkind_annotation) =
       line i ppf "Mod\n";
       jkind_annotation (i+1) ppf jkind;
       modes (i+1) ppf m
-  | With (jkind, type_) ->
+  | With (jkind, type_, modalities_) ->
       line i ppf "With\n";
       jkind_annotation (i+1) ppf jkind;
-      core_type (i+1) ppf type_
+      core_type (i+1) ppf type_;
+      modalities (i+1) ppf modalities_
   | Kind_of type_ ->
       line i ppf "Kind_of\n";
       core_type (i+1) ppf type_

printer/printast_with_mappings.ml

@@ -532,10 +532,11 @@ and jkind_annotation i ppf (jkind : jkind_annotation) =
       line i ppf "Mod\n";
       jkind_annotation (i+1) ppf jkind;
       modes (i+1) ppf m
-  | With (jkind, type_) ->
+  | With (jkind, type_, modalities) ->
       line i ppf "With\n";
       jkind_annotation (i+1) ppf jkind;
-      core_type (i+1) ppf type_
+      core_type (i+1) ppf type_;
+      list i modality ppf modalities
   | Kind_of type_ ->
       line i ppf "Kind_of\n";
       core_type (i+1) ppf type_

testsuite/tests/language-extensions/pprintast_unconditional.ml

@@ -17,6 +17,7 @@ let () = Language_extension.set_universe_and_enable_all
 module Example = struct
   open Parsetree
   open Parse
+  open Asttypes
   open struct
     let loc = Location.none
     let located =  Location.mknoloc
@@ -31,6 +32,10 @@ module Example = struct
   let structure        = parse implementation "include functor F"
   let module_expr      = parse module_expr "struct include functor F end"
   let toplevel_phrase  = parse toplevel_phrase "#2.17;;"
+  let modality         = { txt = Modality "uncontended"
+                         ; loc
+                         }
+  let modalities       = [ modality ]
   let class_field      = { pcf_desc = Pcf_initializer expression
                          ; pcf_loc = loc
                          ; pcf_attributes = []
@@ -98,7 +103,9 @@ module Example = struct
           ( { pjkind_loc = loc;
               pjkind_desc = Abbreviation "value";
             }
-          , core_type );
+          , core_type
+          , modalities
+          );
     }
 
   let mode = { Location.txt = (Parsetree.Mode "global"); loc }

testsuite/tests/language-extensions/pprintast_unconditional.reference

@@ -57,7 +57,7 @@ tyvar_of_name: 'no_tyvars_require_extensions
 
 tyvar: 'no_tyvars_require_extensions
 
-jkind: value with local_ ('a : value) -> unit
+jkind: value with local_ ('a : value) -> unit @@ uncontended
 
 mode: global
 
@@ -122,7 +122,7 @@ tyvar_of_name: 'no_tyvars_require_extensions
 
 tyvar: 'no_tyvars_require_extensions
 
-jkind: value with local_ ('a : value) -> unit
+jkind: value with local_ ('a : value) -> unit @@ uncontended
 
 mode: global
 

testsuite/tests/parsetree/source_jane_street.ml

@@ -1064,18 +1064,40 @@ val inc : 'a with_idx -> 'a with_idx @@ global many = <fun>
 (***************)
 (* Modal kinds *)
 
+(* supported *)
+type 'a list : immutable_data with 'a
+type ('a, 'b) either : immutable_data with 'a * 'b
+type 'a uncontended : immutable_data with 'a @@ uncontended
+type 'a uncontended_with_int : immutable_data with 'a @@ uncontended with int
+
+[%%expect{|
+type 'a list
+  : value mod local with 'a many with 'a uncontended portable with 'a
+              internal with 'a
+type ('a, 'b) either
+  : value mod local with 'a * 'b many with 'a * 'b uncontended
+              portable with 'a * 'b internal with 'a * 'b
+type 'a uncontended
+  : value mod local with 'a many with 'a uncontended portable with 'a
+              internal with 'a
+type 'a uncontended_with_int
+  : value mod local with int
+'a many with int
+'a uncontended
+              portable with int
+'a internal with int
+'a
+|}]
+
+(* not yet supported *)
 module _ : sig
-  type 'a list : immutable_data with 'a
-  type ('a, 'b) either : immutable_data with 'a * 'b
   type 'a gel : kind_of_ 'a mod global
   type 'a t : _
   kind_abbrev_ immediate = value mod global unique many sync uncontended
   kind_abbrev_ immutable_data = value mod sync uncontended many
   kind_abbrev_ immutable = value mod uncontended
   kind_abbrev_ data = value mod sync many
 end = struct
-  type 'a list : immutable_data with 'a
-  type ('a, 'b) either : immutable_data with 'a * 'b
   type 'a gel : kind_of_ 'a mod global
   type 'a t : _
   kind_abbrev_ immediate = value mod global unique many sync uncontended

typing/jkind.ml

@@ -1079,7 +1079,8 @@ module Const = struct
         List.map (of_user_written_annotation_unchecked_level context) ts
       in
       jkind_of_product_annotations jkinds
-    | With (base, type_) -> (
+    | With (base, type_, modalities) -> (
+      ignore modalities;  (* CR aspsmith: TODO *)
       let base = of_user_written_annotation_unchecked_level context base in
       match context with
       | Right_jkind _ -> raise ~loc:type_.ptyp_loc With_on_right