oxcaml · liam923 · Dec 2, 2024 · Nov 29, 2024 · Nov 29, 2024 · Nov 29, 2024
diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml
@@ -230,7 +230,8 @@ module Gen = struct
         | Named (id, in_) ->
           Parsetree.Named
             ( Location.mknoloc (Option.map ~f:Ident.name id),
-              Ptyp_of_type.module_type in_ )
+              Ptyp_of_type.module_type in_,
+              [] )
       in
       Mod.functor_ param @@ module_ env out
     | Mty_alias path ->

diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml
@@ -68,7 +68,7 @@ exception
 let path_and_loc_of_cstr desc _ =
   let open Types in
   match desc.cstr_tag with
-  | Extension (path, _) -> (path, desc.cstr_loc)
+  | Extension path -> (path, desc.cstr_loc)
   | _ -> (
     match get_desc desc.cstr_res with
     | Tconstr (path, _, _) -> (path, desc.cstr_loc)

diff --git a/src/analysis/ptyp_of_type.ml b/src/analysis/ptyp_of_type.ml
@@ -23,7 +23,9 @@ let rec module_type =
       | Unit -> Parsetree.Unit
       | Named (id, type_in) ->
         Parsetree.Named
-          (Location.mknoloc (Option.map ~f:Ident.name id), module_type type_in)
+          ( Location.mknoloc (Option.map ~f:Ident.name id),
+            module_type type_in,
+            [] )
     in
     let out = module_type type_out in
     Mty.functor_ param out
@@ -170,7 +172,7 @@ and value_description id
     pval_loc = val_loc
   }
 
-and constructor_argument { ca_type; ca_loc; ca_modalities } =
+and constructor_argument { ca_type; ca_loc; ca_modalities; ca_jkind = _ } =
   { Parsetree.pca_type = core_type ca_type;
     pca_loc = ca_loc;
     pca_modalities = const_modalities ~attrs:[] ca_modalities

diff --git a/src/ocaml/parsing/ast_helper.ml b/src/ocaml/parsing/ast_helper.ml
@@ -284,7 +284,7 @@ module Mty = struct
   let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
   let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
   let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
-  let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
+  let functor_ ?loc ?attrs ?(ret_mode=[]) a b = mk ?loc ?attrs (Pmty_functor (a, b, ret_mode))
   let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
   let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
@@ -302,7 +302,8 @@ module Mod = struct
     mk ?loc ?attrs (Pmod_functor (arg, body))
   let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
   let apply_unit ?loc ?attrs m1 = mk ?loc ?attrs (Pmod_apply_unit m1)
-  let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
+  let constraint_ ?loc ?attrs ty mode m =
+    mk ?loc ?attrs (Pmod_constraint (m, ty, mode))
   let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a)
   let instance ?loc ?attrs a = mk ?loc ?attrs (Pmod_instance a)
@@ -473,10 +474,11 @@ end
 
 module Md = struct
   let mk ?(loc = !default_loc) ?(attrs = [])
-        ?(docs = empty_docs) ?(text = []) name typ =
+        ?(docs = empty_docs) ?(text = []) ?(modalities=[]) name typ =
     {
      pmd_name = name;
      pmd_type = typ;
+     pmd_modalities = modalities;
      pmd_attributes =
        add_text_attrs text (add_docs_attrs docs attrs);
      pmd_loc = loc;

diff --git a/src/ocaml/parsing/ast_helper.mli b/src/ocaml/parsing/ast_helper.mli
@@ -287,7 +287,7 @@ module Mty:
     val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
     val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
     val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
-    val functor_: ?loc:loc -> ?attrs:attrs ->
+    val functor_: ?loc:loc -> ?attrs:attrs -> ?ret_mode:modes ->
       functor_parameter -> module_type -> module_type
     val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
       with_constraint list -> module_type
@@ -310,8 +310,8 @@ module Mod:
     val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
       module_expr
     val apply_unit: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr
-    val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
-      module_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> module_type option -> modes ->
+      module_expr -> module_expr
     val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr
     val instance: ?loc:loc -> ?attrs:attrs -> module_instance -> module_expr
@@ -379,7 +379,7 @@ module Str:
 (** Module declarations *)
 module Md:
   sig
-    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> ?modalities:modalities ->
       str_opt -> module_type -> module_declaration
   end
 

diff --git a/src/ocaml/parsing/ast_iterator.ml b/src/ocaml/parsing/ast_iterator.ml
@@ -265,9 +265,10 @@ end
 
 let iter_functor_param sub = function
   | Unit -> ()
-  | Named (name, mty) ->
+  | Named (name, mty, mm) ->
     iter_loc sub name;
-    sub.module_type sub mty
+    sub.module_type sub mty;
+    sub.modes sub mm
 
 module MT = struct
   (* Type expressions for the module language *)
@@ -279,9 +280,10 @@ module MT = struct
     | Pmty_ident s -> iter_loc sub s
     | Pmty_alias s -> iter_loc sub s
     | Pmty_signature sg -> sub.signature sub sg
-    | Pmty_functor (param, mt2) ->
+    | Pmty_functor (param, mt2, mm2) ->
         iter_functor_param sub param;
-        sub.module_type sub mt2
+        sub.module_type sub mt2;
+        sub.modes sub mm2
     | Pmty_with (mt, l) ->
         sub.module_type sub mt;
         List.iter (sub.with_constraint sub) l
@@ -353,8 +355,9 @@ module M = struct
         sub.module_expr sub m2
     | Pmod_apply_unit m1 ->
         sub.module_expr sub m1
-    | Pmod_constraint (m, mty) ->
-        sub.module_expr sub m; sub.module_type sub mty
+    | Pmod_constraint (m, mty, mm) ->
+        sub.module_expr sub m; Option.iter (sub.module_type sub) mty;
+        sub.modes sub mm
     | Pmod_unpack e -> sub.expr sub e
     | Pmod_extension x -> sub.extension sub x
     | Pmod_instance _ -> ()

diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml
@@ -320,7 +320,7 @@ end
 
 let map_functor_param sub = function
   | Unit -> Unit
-  | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
+  | Named (s, mt, mm) -> Named (map_loc sub s, sub.module_type sub mt, sub.modes sub mm)
 
 module MT = struct
   (* Type expressions for the module language *)
@@ -333,8 +333,8 @@ module MT = struct
     | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
     | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
     | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
-    | Pmty_functor (param, mt) ->
-        functor_ ~loc ~attrs
+    | Pmty_functor (param, mt, mm) ->
+        functor_ ~loc ~attrs ~ret_mode:(sub.modes sub mm)
           (map_functor_param sub param)
           (sub.module_type sub mt)
     | Pmty_with (mt, l) ->
@@ -414,9 +414,9 @@ module M = struct
         apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
     | Pmod_apply_unit m1 ->
         apply_unit ~loc ~attrs (sub.module_expr sub m1)
-    | Pmod_constraint (m, mty) ->
-        constraint_ ~loc ~attrs (sub.module_expr sub m)
-                    (sub.module_type sub mty)
+    | Pmod_constraint (m, mty, mm) ->
+        constraint_ ~loc ~attrs (Option.map (sub.module_type sub) mty) (sub.modes sub mm)
+          (sub.module_expr sub m)
     | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
     | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
     | Pmod_instance x ->

diff --git a/src/ocaml/parsing/language_extension.ml b/src/ocaml/parsing/language_extension.ml
@@ -62,7 +62,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   function
   | Comprehensions -> (module Unit)
   | Mode -> (module Maturity)
-  | Unique -> (module Unit)
+  | Unique -> (module Maturity)
   | Include_functor -> (module Unit)
   | Polymorphic_parameters -> (module Unit)
   | Immutable_arrays -> (module Unit)
@@ -87,13 +87,17 @@ let is_erasable : type a. a t -> bool = function
   | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances ->
     false
 
+let maturity_of_unique_for_drf = Alpha
+
+let maturity_of_unique_for_destruction = Alpha
+
 module Exist_pair = struct
   type t = Pair : 'a language_extension * 'a -> t
 
   let maturity : t -> Maturity.t = function
     | Pair (Comprehensions, ()) -> Beta
     | Pair (Mode, m) -> m
-    | Pair (Unique, ()) -> Alpha
+    | Pair (Unique, m) -> m
     | Pair (Include_functor, ()) -> Stable
     | Pair (Polymorphic_parameters, ()) -> Stable
     | Pair (Immutable_arrays, ()) -> Stable
@@ -109,11 +113,12 @@ module Exist_pair = struct
   let to_string = function
     | Pair (Layouts, m) -> to_string Layouts ^ "_" ^ maturity_to_string m
     | Pair (Mode, m) -> to_string Mode ^ "_" ^ maturity_to_string m
+    | Pair (Unique, m) -> to_string Unique ^ "_" ^ maturity_to_string m
     | Pair (Small_numbers, m) ->
       to_string Small_numbers ^ "_" ^ maturity_to_string m
     | Pair (SIMD, m) -> to_string SIMD ^ "_" ^ maturity_to_string m
     | Pair
-        ( (( Comprehensions | Unique | Include_functor | Polymorphic_parameters
+        ( (( Comprehensions | Include_functor | Polymorphic_parameters
            | Immutable_arrays | Module_strengthening | Labeled_tuples
            | Instances ) as ext),
           _ ) ->
@@ -129,7 +134,9 @@ module Exist_pair = struct
     | "mode" -> Some (Pair (Mode, Stable))
     | "mode_beta" -> Some (Pair (Mode, Beta))
     | "mode_alpha" -> Some (Pair (Mode, Alpha))
-    | "unique" -> Some (Pair (Unique, ()))
+    | "unique" -> Some (Pair (Unique, Stable))
+    | "unique_beta" -> Some (Pair (Unique, Beta))
+    | "unique_alpha" -> Some (Pair (Unique, Alpha))
     | "include_functor" -> Some (Pair (Include_functor, ()))
     | "polymorphic_parameters" -> Some (Pair (Polymorphic_parameters, ()))
     | "immutable_arrays" -> Some (Pair (Immutable_arrays, ()))

diff --git a/src/ocaml/parsing/language_extension.mli b/src/ocaml/parsing/language_extension.mli
@@ -20,7 +20,7 @@ end
 type 'a t = 'a Language_extension_kernel.t =
   | Comprehensions : unit t
   | Mode : maturity t
-  | Unique : unit t
+  | Unique : maturity t
   | Include_functor : unit t
   | Polymorphic_parameters : unit t
   | Immutable_arrays : unit t
@@ -35,6 +35,10 @@ type 'a t = 'a Language_extension_kernel.t =
     else throw an exception at the provided location saying otherwise. *)
 val assert_enabled : loc:Location.t -> 'a t -> 'a -> unit
 
+val maturity_of_unique_for_drf : maturity
+
+val maturity_of_unique_for_destruction : maturity
+
 (** Existentially packed language extension *)
 module Exist : sig
   type 'a extn = 'a t

diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml
@@ -142,6 +142,7 @@ type 'a loc = {
 let mkloc txt loc = { txt ; loc }
 let mknoloc txt = mkloc txt none
 let get_txt { txt } = txt
+let get_loc { loc } = loc
 let map f { txt; loc} = {txt = f txt; loc}
 let compare_txt f { txt=t1 } { txt=t2 } = f t1 t2
 

diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli
@@ -106,6 +106,7 @@ type 'a loc = {
 val mknoloc : 'a -> 'a loc
 val mkloc : 'a -> t -> 'a loc
 val get_txt : 'a loc -> 'a
+val get_loc : 'a loc -> t
 val map : ('a -> 'b) -> 'a loc -> 'b loc
 val compare_txt : ('a -> 'b -> 'c) -> 'a loc -> 'b loc -> 'c
 

diff --git a/src/ocaml/parsing/parsetree.mli b/src/ocaml/parsing/parsetree.mli
@@ -1002,8 +1002,8 @@ and module_type =
 and module_type_desc =
   | Pmty_ident of Longident.t loc  (** [Pmty_ident(S)] represents [S] *)
   | Pmty_signature of signature  (** [sig ... end] *)
-  | Pmty_functor of functor_parameter * module_type
-      (** [functor(X : MT1) -> MT2] *)
+  | Pmty_functor of functor_parameter * module_type * modes
+      (** [functor(X : MT1 @@ modes) -> MT2 @ modes] *)
   | Pmty_with of module_type * with_constraint list  (** [MT with ...] *)
   | Pmty_typeof of module_expr  (** [module type of ME] *)
   | Pmty_extension of extension  (** [[%id]] *)
@@ -1013,10 +1013,10 @@ and module_type_desc =
 
 and functor_parameter =
   | Unit  (** [()] *)
-  | Named of string option loc * module_type
+  | Named of string option loc * module_type * modes
       (** [Named(name, MT)] represents:
-            - [(X : MT)] when [name] is [Some X],
-            - [(_ : MT)] when [name] is [None] *)
+            - [(X : MT @@ modes)] when [name] is [Some X],
+            - [(_ : MT @@ modes)] when [name] is [None] *)
 
 and signature =
   {
@@ -1065,6 +1065,7 @@ and module_declaration =
     {
      pmd_name: string option loc;
      pmd_type: module_type;
+     pmd_modalities: modalities;
      pmd_attributes: attributes;  (** [... [\@\@id1] [\@\@id2]] *)
      pmd_loc: Location.t;
     }
@@ -1165,7 +1166,11 @@ and module_expr_desc =
       (** [functor(X : MT1) -> ME] *)
   | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *)
   | Pmod_apply_unit of module_expr (** [ME1()] *)
-  | Pmod_constraint of module_expr * module_type  (** [(ME : MT)] *)
+  | Pmod_constraint of module_expr * module_type option * modes
+      (** - [(ME : MT @@ modes)]
+          - [(ME @ modes)]
+          - [(ME : MT)]
+      *)
   | Pmod_unpack of expression  (** [(val E)] *)
   | Pmod_extension of extension  (** [[%id]] *)
   | Pmod_instance of module_instance