Migrate modality annotations into the parsetree

ocaml/ocamldoc/odoc_sig.ml

@@ -461,7 +461,7 @@ module Analyser =
             let comment_opt = analyze_alerts comment_opt cd_attributes in
             let vc_args =
               match cd_args with
-              | Cstr_tuple l -> Cstr_tuple (List.map (fun (ty, _) -> Odoc_env.subst_type env ty) l)
+              | Cstr_tuple l -> Cstr_tuple (List.map (fun {ca_type=ty; _} -> Odoc_env.subst_type env ty) l)
               | Cstr_record l ->
                   Cstr_record (List.map (get_field env name_comment_list) l)
             in
@@ -499,7 +499,7 @@ module Analyser =
       let open Typedtree in
       function
       | Cstr_tuple l ->
-          Odoc_type.Cstr_tuple (List.map (fun (ty, _) -> tuple ty) l)
+          Odoc_type.Cstr_tuple (List.map (fun {ca_type=ty; _} -> tuple ty) l)
       | Cstr_record l ->
           let comments = Record.(doc typedtree) pos_end l in
           Odoc_type.Cstr_record (List.map (record comments) l)
@@ -976,7 +976,7 @@ module Analyser =
               let xt_args =
                 match types_ext.ext_args with
                 | Cstr_tuple l ->
-                    Cstr_tuple (List.map (fun (ty, _) -> Odoc_env.subst_type new_env ty) l)
+                    Cstr_tuple (List.map (fun {ca_type=ty; _} -> Odoc_env.subst_type new_env ty) l)
                 | Cstr_record l ->
                     let docs = Record.(doc types ext_loc_end) l in
                     Cstr_record (List.map (get_field new_env docs) l)
@@ -1022,7 +1022,7 @@ module Analyser =
             let ex_args =
               let pos_end = Loc.end_ types_ext.ext_loc in
               match types_ext.ext_args with
-              | Cstr_tuple l -> Cstr_tuple (List.map (fun (ty, _) -> Odoc_env.subst_type env ty) l)
+              | Cstr_tuple l -> Cstr_tuple (List.map (fun {ca_type=ty; _} -> Odoc_env.subst_type env ty) l)
               | Cstr_record l ->
                   let docs = Record.(doc types) pos_end l in
                   Cstr_record (List.map (get_field env docs) l)

ocaml/parsing/ast_helper.ml

@@ -550,11 +550,19 @@ module Type = struct
      pcd_attributes = add_info_attrs info attrs;
     }
 
+  let constructor_arg ?(loc = !default_loc) ?(modalities = []) typ =
+    {
+      pca_modalities = modalities;
+      pca_type = typ;
+      pca_loc = loc;
+    }
+
   let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
-        ?(mut = Immutable) name typ =
+        ?(mut = Immutable) ?(modalities = []) name typ =
     {
      pld_name = name;
      pld_mutable = mut;
+     pld_modalities = modalities;
      pld_type = typ;
      pld_loc = loc;
      pld_attributes = add_info_attrs info attrs;

ocaml/parsing/ast_helper.mli

@@ -226,8 +226,13 @@ module Type:
       ?vars:str list -> ?args:constructor_arguments -> ?res:core_type ->
       str ->
       constructor_declaration
+
+    val constructor_arg: ?loc:loc -> ?modalities:modality with_loc list -> core_type ->
+      constructor_argument
+
     val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
-      ?mut:mutable_flag -> str -> core_type -> label_declaration
+      ?mut:mutable_flag -> ?modalities:modality with_loc list -> str -> core_type ->
+      label_declaration
   end
 
 (** Type extensions *)

ocaml/parsing/ast_iterator.ml

@@ -222,8 +222,16 @@ 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;
+    iter_modalities sub pca_modalities
+
   let iter_constructor_arguments sub = function
-    | Pcstr_tuple l -> List.iter (sub.typ sub) l
+    | Pcstr_tuple l -> List.iter (iter_constructor_argument sub) l
     | Pcstr_record l ->
         List.iter (sub.label_declaration sub) l
 
@@ -944,11 +952,12 @@ let default_iterator =
       );
 
     label_declaration =
-      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_modalities; pld_attributes}->
          iter_loc this pld_name;
          this.typ this pld_type;
          this.location this pld_loc;
-         this.attributes this pld_attributes
+         this.attributes this pld_attributes;
+         T.iter_modalities this pld_modalities
       );
 
     cases = (fun this l -> List.iter (this.case this) l);

ocaml/parsing/ast_mapper.ml

@@ -263,8 +263,17 @@ 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
+    let pca_modalities = map_modalities sub x.pca_modalities in
+    { pca_type; pca_loc; pca_modalities }
+
   let map_constructor_arguments sub = function
-    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+    | Pcstr_tuple l -> Pcstr_tuple (List.map (map_constructor_argument sub) l)
     | Pcstr_record l ->
         Pcstr_record (List.map (sub.label_declaration sub) l)
 
@@ -1046,11 +1055,12 @@ let default_mapper =
       );
 
     label_declaration =
-      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_modalities; pld_attributes} ->
          Type.field
            (map_loc this pld_name)
            (this.typ this pld_type)
            ~mut:pld_mutable
+           ~modalities:(T.map_modalities this pld_modalities)
            ~loc:(this.location this pld_loc)
            ~attrs:(this.attributes this pld_attributes)
       );

ocaml/parsing/depend.ml

@@ -157,7 +157,7 @@ let add_opt add_fn bv = function
   | Some x -> add_fn bv x
 
 let add_constructor_arguments bv = function
-  | Pcstr_tuple l -> List.iter (add_type bv) l
+  | Pcstr_tuple l -> List.iter (fun a -> add_type bv a.pca_type) l
   | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
 
 let add_constructor_decl bv pcd =

ocaml/parsing/jane_syntax.mli

@@ -105,14 +105,12 @@ module Mode_expr : sig
   - let local_ x = ...
   - local_ exp
   - local string -> string
-  - {global_ x : int}
 
   Note that in the first two cases, axes other than locality are not specified;
-  in the second case, other axes are defaulted to legacy. In the last case, we
-  are specifying modalities.
+  in the second case, other axes are defaulted to legacy.
 
-  In the future the three annotations will be quite different, but for now they
-  are all lists of modes/modalities. [Typemode] has the three different
+  In the future the two annotations will be quite different, but for now they
+  are just lists of modes. [Typemode] has the two different
   interpretations of the annotation.
 
   (TODO: in the future we will have mutable(...), which is similar to the second

ocaml/parsing/parser.mly

@@ -4056,16 +4056,15 @@ generalized_constructor_arguments:
                                   { ($2,Pcstr_tuple [],Some $4) }
 ;
 
-%inline atomic_type_with_modality:
-  gbl = global_flag cty = atomic_type m1 = optional_atat_mode_expr {
-    let m = Mode.concat gbl m1 in
-    mktyp_with_modes m cty
-}
+%inline constructor_argument:
+  gbl=global_flag cty=atomic_type m1=optional_atat_modalities_expr {
+    let modalities = gbl @ m1 in
+    Type.constructor_arg cty ~modalities ~loc:(make_loc $sloc)
+  }
 ;
 
 constructor_arguments:
-  | tys = inline_separated_nonempty_llist(STAR, atomic_type_with_modality)
-    %prec below_HASH
+  | tys = inline_separated_nonempty_llist(STAR, constructor_argument)
       { Pcstr_tuple tys }
   | LBRACE label_declarations RBRACE
       { Pcstr_record $2 }
@@ -4076,25 +4075,23 @@ label_declarations:
   | label_declaration_semi label_declarations   { $1 :: $2 }
 ;
 label_declaration:
-    mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr m1=optional_atat_mode_expr attrs=attributes
+    mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr m1=optional_atat_modalities_expr attrs=attributes
       { let info = symbol_info $endpos in
         let mut, m0 = $1 in
-        let m = Mode.concat m0 m1 in
-        let typ = mktyp_with_modes m $4 in
-        Type.field $2 typ ~mut ~attrs ~loc:(make_loc $sloc) ~info}
+        let modalities = m0 @ m1 in
+        Type.field $2 $4 ~mut ~modalities ~attrs ~loc:(make_loc $sloc) ~info}
 ;
 label_declaration_semi:
-    mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr m1=optional_atat_mode_expr attrs0=attributes
+    mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr m1=optional_atat_modalities_expr attrs0=attributes
       SEMI attrs1=attributes
       { let info =
           match rhs_info $endpos(attrs0) with
           | Some _ as info_before_semi -> info_before_semi
           | None -> symbol_info $endpos
        in
        let mut, m0 = $1 in
-       let m = Mode.concat m0 m1 in
-       let typ = mktyp_with_modes m $4 in
-       Type.field $2 typ ~mut ~attrs:(attrs0 @ attrs1) ~loc:(make_loc $sloc) ~info}
+       let modalities = m0 @ m1 in
+       Type.field $2 $4 ~mut ~modalities ~attrs:(attrs0 @ attrs1) ~loc:(make_loc $sloc) ~info}
 ;
 
 /* Type Extensions */
@@ -4422,6 +4419,21 @@ atat_mode_expr:
   | atat_mode_expr {$1}
 ;
 
+/* Modalities */
+
+%inline modality:
+  | LIDENT { mkloc (Modality $1) (make_loc $sloc) }
+
+%inline modalities:
+  | modality+ { $1 }
+
+optional_atat_modalities_expr:
+  | %prec below_HASH
+    { [] }
+  | ATAT modalities { $2 }
+  | ATAT error { expecting $loc($2) "modality expression" }
+;
+
 %inline param_type:
   | mktyp_jane_syntax_ltyp(
     LPAREN bound_vars = typevar_list DOT inner_type = core_type RPAREN
@@ -4858,15 +4870,15 @@ mutable_flag:
 ;
 mutable_or_global_flag:
     /* empty */
-    { Immutable, Mode.empty }
+    { Immutable, [] }
   | MUTABLE
-    { Mutable, Mode.empty }
+    { Mutable, [] }
   | GLOBAL
-    { Immutable, Mode.singleton (Mode.Const.mk "global" (make_loc $sloc)) }
+    { Immutable, [ mkloc (Modality "global") (make_loc $sloc)] }
 ;
 %inline global_flag:
-           { Mode.empty }
-  | GLOBAL { Mode.singleton (Mode.Const.mk "global" (make_loc $sloc)) }
+           { [] }
+  | GLOBAL { [ mkloc (Modality "global") (make_loc $sloc)] }
 ;
 virtual_flag:
     /* empty */                                 { Concrete }

ocaml/parsing/parsetree.mli

@@ -45,6 +45,8 @@ type constant =
 
 type location_stack = Location.t list
 
+type modality = | Modality of string [@@unboxed]
+
 (** {1 Extension points} *)
 
 type attribute = {
@@ -530,6 +532,7 @@ and label_declaration =
     {
      pld_name: string loc;
      pld_mutable: mutable_flag;
+     pld_modalities: modality loc list;
      pld_type: core_type;
      pld_loc: Location.t;
      pld_attributes: attributes;  (** [l : T [\@id1] [\@id2]] *)
@@ -555,8 +558,15 @@ and constructor_declaration =
      pcd_attributes: attributes;  (** [C of ... [\@id1] [\@id2]] *)
     }
 
+and constructor_argument =
+  {
+    pca_modalities: modality loc list;
+    pca_type: core_type;
+    pca_loc: Location.t;
+  }
+
 and constructor_arguments =
-  | Pcstr_tuple of core_type list
+  | Pcstr_tuple of constructor_argument list
   | Pcstr_record of label_declaration list
       (** Values of type {!constructor_declaration}
     represents the constructor arguments of:

ocaml/parsing/pprintast.ml

@@ -311,7 +311,6 @@ let legacy_mode f m =
     | "local" -> "local_"
     | "unique" -> "unique_"
     | "once" -> "once_"
-    | "global" -> "global_" (* global modality *)
     | s -> Misc.fatal_errorf "Unrecognized mode %s - should not parse" s
   in
   pp_print_string f s
@@ -326,6 +325,25 @@ let optional_legacy_modes f m =
     legacy_modes f m;
     pp_print_space f ()
 
+let legacy_modality f m =
+  let {txt; _} = (m : modality Location.loc) in
+  let s =
+    match txt with
+    | Modality "global" -> "global_"
+    | Modality s -> Misc.fatal_errorf "Unrecognized modality %s - should not parse" s
+  in
+  pp_print_string f s
+
+let legacy_modalities f m =
+  pp_print_list ~pp_sep:(fun f () -> pp f " ") legacy_modality f m
+
+let optional_legacy_modalities f m =
+  match m with
+  | [] -> ()
+  | m ->
+    legacy_modalities f m;
+    pp_print_space f ()
+
 let mode f m =
   let {txt; _} = (m : Jane_syntax.Mode_expr.Const.t :> _ Location.loc) in
   pp_print_string f txt
@@ -349,6 +367,12 @@ let maybe_type_atat_modes pty ctxt f c =
   | 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
+  | m ->
+    pp f "%a %a" legacy_modalities m (pty ctxt) pca.pca_type
+
 (* c ['a,'b] *)
 let rec class_params_def ctxt f =  function
   | [] -> ()
@@ -1833,15 +1857,11 @@ and type_def_list ctxt f (rf, exported, l) =
 
 and record_declaration ctxt f lbls =
   let type_record_field f pld =
-    let modalities, ptyp_attributes =
-      Jane_syntax.Mode_expr.maybe_of_attrs pld.pld_type.ptyp_attributes
-    in
-    let pld_type = {pld.pld_type with ptyp_attributes} in
     pp f "@[<2>%a%a%s:@;%a@;%a@]"
       mutable_flag pld.pld_mutable
-      optional_legacy_modes modalities
+      optional_legacy_modalities pld.pld_modalities
       pld.pld_name.txt
-      (core_type ctxt) pld_type
+      (core_type ctxt) pld.pld_type
       (attributes ctxt) pld.pld_attributes
   in
   pp f "{@\n%a}"
@@ -1932,7 +1952,7 @@ and constructor_declaration ctxt f (name, vars_jkinds, args, res, attrs) =
         (fun f -> function
            | Pcstr_tuple [] -> ()
            | Pcstr_tuple l ->
-             pp f "@;of@;%a" (list (maybe_modes_type core_type1 ctxt) ~sep:"@;*@;") l
+             pp f "@;of@;%a" (list (modalities_type core_type1 ctxt) ~sep:"@;*@;") l
            | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
         ) args
         (attributes ctxt) attrs
@@ -1942,7 +1962,7 @@ and constructor_declaration ctxt f (name, vars_jkinds, args, res, attrs) =
         (fun f -> function
            | Pcstr_tuple [] -> core_type1 ctxt f r
            | Pcstr_tuple l -> pp f "%a@;->@;%a"
-                                (list (maybe_modes_type core_type1 ctxt) ~sep:"@;*@;") l
+                                (list (modalities_type core_type1 ctxt) ~sep:"@;*@;") l
                                 (core_type1 ctxt) r
            | Pcstr_record l ->
                pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r