Merge 5.2.0minus-5

.github/workflows/flambda-backend.yml

@@ -38,7 +38,7 @@ jobs:
         path: 'merlin-jst'
 
     - name: Set up OCaml ${{ matrix.ocaml-compiler }}
-      uses: ocaml/setup-ocaml@v2
+      uses: ocaml/setup-ocaml@v3
       with:
         # Version of the OCaml compiler to initialise
         ocaml-compiler: ${{ matrix.ocaml-compiler }}

src/analysis/completion.ml

@@ -124,8 +124,8 @@ let classify_node = function
   | Class_description _ -> `Type
   | Class_type_declaration _ -> `Type
   | Method_call _ -> `Expression
-  | Record_field (`Expression _, _, _) -> `Expression
-  | Record_field (`Pattern _, _, _) -> `Pattern
+  | Record_field (`Expression _, _, _, _) -> `Expression
+  | Record_field (`Pattern _, _, _, _) -> `Pattern
   | Module_binding_name _ -> `Module
   | Module_declaration_name _ -> `Module
   | Module_type_declaration_name _ -> `Module_type
@@ -285,7 +285,10 @@ let fold_sumtype_constructors ~env ~init ~f t =
     begin
       match Env.find_type_descrs path env with
       | exception Not_found -> init
-      | Type_record _ | Type_abstract _ | Type_open -> init
+      | Type_record _
+      | Type_record_unboxed_product _
+      | Type_abstract _
+      | Type_open -> init
       | Type_variant (constrs, _) -> List.fold_right constrs ~init ~f
     end
   | _ -> init
@@ -460,14 +463,15 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env
               :: candidates)
           prefix_path env []
       | `Labels ->
-        Env.fold_labels
-          (fun ({ Types.lbl_name = name; _ } as l) candidates ->
-            if not (validate `Lident `Label name) then candidates
-            else
-              make_weighted_candidate ~exact:(name = prefix) name (`Label l)
-                ~attrs:(lbl_attributes l)
-              :: candidates)
-          prefix_path env []
+        let step ({ Types.lbl_name = name; _ } as l) candidates =
+          if not (validate `Lident `Label name) then candidates
+          else
+            make_weighted_candidate ~exact:(name = prefix) name (`Label l)
+              ~attrs:(lbl_attributes l)
+            :: candidates
+        in
+        Env.fold_labels Legacy step prefix_path env []
+        @ Env.fold_labels Unboxed_product step prefix_path env []
     in
     let of_kind_group = function
       | #Query_protocol.Compl.kind as k -> of_kind k
@@ -528,10 +532,10 @@ let complete_methods ~env ~prefix obj =
       })
 
 type is_label =
-  [ `No
-  | `Maybe
-  | `Description of Types.label_description list
-  | `Declaration of Types.type_expr * Types.label_declaration list ]
+  | No
+  | Maybe
+  | Description : 'rep Types.gen_label_description list -> is_label
+  | Declaration of Types.type_expr * Types.label_declaration list
 
 let complete_prefix ?get_doc ?target_type ?(kinds = []) ~keywords ~prefix
     ~is_label config (env, node) branch =
@@ -585,11 +589,14 @@ let complete_prefix ?get_doc ?target_type ?(kinds = []) ~keywords ~prefix
     in
     let base_completion =
       match (is_label : is_label) with
-      | `No -> []
-      | `Maybe -> Env.fold_labels add_label_description prefix_path env []
-      | `Description lbls ->
+      | No -> []
+      | Maybe ->
+        Env.fold_labels Legacy add_label_description prefix_path env []
+        @ Env.fold_labels Unboxed_product add_label_description prefix_path env
+            []
+      | Description lbls ->
         List.fold_right ~f:add_label_description lbls ~init:[]
-      | `Declaration (ty, decls) ->
+      | Declaration (ty, decls) ->
         List.fold_right ~f:(add_label_declaration ty) decls ~init:[]
     in
     if base_completion = [] then
@@ -671,15 +678,15 @@ let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix =
           match Types.get_desc t with
           | Types.Tconstr (p, _, _) -> (
             match (Env.find_type p env).Types.type_kind with
-            | Types.Type_record (labels, _) -> `Declaration (t, labels)
-            | _ -> `Maybe)
-          | _ -> `Maybe
-        with _ -> `Maybe
+            | Types.Type_record (labels, _) -> Declaration (t, labels)
+            | _ -> Maybe)
+          | _ -> Maybe
+        with _ -> Maybe
       in
       let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in
       complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label
         buffer (env, node) branch
-    | Record_field (parent, lbl, _) ->
+    | Record_field (parent, lbl, _, _) ->
       let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in
       let snap = Btype.snapshot () in
       let is_label =
@@ -712,15 +719,15 @@ let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix =
                       { lbl with Types.lbl_res; lbl_arg }
                     with _ -> lbl)
               in
-              `Description labels
+              Description labels
             with _ -> (
               match decl.Types.type_kind with
-              | Types.Type_record (lbls, _) -> `Declaration (ty, lbls)
-              | _ -> `Maybe)
+              | Types.Type_record (lbls, _) -> Declaration (ty, lbls)
+              | _ -> Maybe)
           end
-          | _ | (exception _) -> `Maybe
+          | _ | (exception _) -> Maybe
         end
-        | lbls -> `Description (Array.to_list lbls)
+        | lbls -> Description (Array.to_list lbls)
       in
       let result =
         complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label
@@ -731,7 +738,7 @@ let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix =
     | _ ->
       let prefix, is_label = Longident.(keep_suffix @@ parse prefix) in
       complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix buffer
-        ~is_label:(if is_label then `Maybe else `No)
+        ~is_label:(if is_label then Maybe else No)
         (env, node) branch)
 
 let expand_prefix ~global_modules ?(kinds = []) env prefix =

src/analysis/construct.ml

@@ -451,7 +451,7 @@ module Gen = struct
         |> List.flatten |> List.rev
     in
 
-    let record env typ path labels =
+    let record env typ path labels record_form =
       log ~title:"record labels" "[%s]"
         (String.concat ~sep:"; "
            (List.map labels ~f:(fun l -> l.Types.lbl_name)));
@@ -461,8 +461,9 @@ module Gen = struct
             let _, arg, res = Ctype.instance_label ~fixed:true lbl in
             Ctype.unify env res typ;
             let lid =
-              Util.maybe_prefix env ~env_check:Env.find_label_by_name path
-                lbl_name
+              Util.maybe_prefix env
+                ~env_check:(Env.find_label_by_name record_form)
+                path lbl_name
               |> Location.mknoloc
             in
             let exprs = exp_or_hole env arg in
@@ -504,7 +505,9 @@ module Gen = struct
             let def = Env.find_type_descrs path env in
             match def with
             | Type_variant (constrs, _) -> constructor env rtyp path constrs
-            | Type_record (labels, _) -> record env rtyp path labels
+            | Type_record (labels, _) -> record env rtyp path labels Legacy
+            | Type_record_unboxed_product (labels, _) ->
+              record env rtyp path labels Unboxed_product
             | Type_abstract _ | Type_open -> [])
         end
         | Tarrow _ ->
@@ -532,7 +535,12 @@ module Gen = struct
           let arguments, body_type, env = left_types [] env rtyp in
           let exps = arrow_rhs env body_type in
           List.map exps ~f:(fun e ->
-              Ast_helper.Exp.function_ arguments None (Pfunction_body e))
+              Ast_helper.Exp.function_ arguments
+                { mode_annotations = [];
+                  ret_mode_annotations = [];
+                  ret_type_constraint = None
+                }
+                (Pfunction_body e))
         | Ttuple types ->
           let choices =
             List.map types ~f:(fun (lbl, ty) ->

src/analysis/context.ml

@@ -37,7 +37,9 @@ type t =
        path (cf. #486, #794). *)
   | Unknown_constructor
   | Expr
-  | Label of Types.label_description (* Similar to constructors. *)
+  | Label :
+      'rep Types.gen_label_description * 'rep Types.record_form
+      -> t (* Similar to constructors. *)
   | Unknown_label
   | Module_path
   | Module_type
@@ -50,8 +52,10 @@ let to_string = function
   | Constructor (cd, _) -> Printf.sprintf "constructor %s" cd.cstr_name
   | Unknown_constructor -> Printf.sprintf "unknown constructor"
   | Expr -> "expression"
-  | Label lbl -> Printf.sprintf "record field %s" lbl.lbl_name
-  | Unknown_label -> Printf.sprintf "record field"
+  | Label (lbl, Legacy) -> Printf.sprintf "record field %s" lbl.lbl_name
+  | Label (lbl, Unboxed_product) ->
+    Printf.sprintf "unboxed record field %s" lbl.lbl_name
+  | Unknown_label -> Printf.sprintf "(unboxed?) record field"
   | Module_path -> "module path"
   | Module_type -> "module type"
   | Patt -> "pattern"
@@ -158,9 +162,10 @@ let inspect_browse_tree ?let_pun_behavior ~cursor lid browse : t option =
     | Module_type _ -> Some Module_type
     | Core_type { ctyp_desc = Ttyp_package _; _ } -> Some Module_type
     | Core_type _ -> Some Type
-    | Record_field (_, lbl, _) when Longident.last lid = lbl.lbl_name ->
+    | Record_field (_, lbl, record_form, _)
+      when Longident.last lid = lbl.lbl_name ->
       (* if we stopped here, then we're on the label itself, and whether or
           not punning is happening is not important *)
-      Some (Label lbl)
+      Some (Label (lbl, record_form))
     | Expression e -> Some (inspect_expression ~cursor ~lid e)
     | _ -> Some Unknown)

src/analysis/context.mli

@@ -33,7 +33,9 @@ type t =
        path (cf. #486, #794). *)
   | Unknown_constructor
   | Expr
-  | Label of Types.label_description (* Similar to constructors. *)
+  | Label :
+      'rep Types.gen_label_description * 'rep Types.record_form
+      -> t (* Similar to constructors. *)
   | Unknown_label
   | Module_path
   | Module_type