Merge pull request #1940 from voodoos/414-4.19-backports

414 4.19 backports

Author: voodoos

.git-blame-ignore-revs

@@ -1,2 +1,3 @@
 # git config blame.ignoreRevsFile .git-blame-ignore-revs
 beb4b4c5ed38984534effc3cc8733db57820bc7b
+013987e10b9ed17a8e06e9e4e859070482254ab2

.github/workflows/main.yml

@@ -6,27 +6,27 @@ name: CI
 # events but only for the master branch
 on:
   push:
-    branches: [ '414' ]
+    branches: ["414"]
     paths-ignore:
-      - '**.md'
-      - '**.txt'
-      - '.git*'
-      - 'doc/**'
-      - 'emacs/**'
-      - 'vim/**'
-      - '**/emacs-lint.yml'
+      - "**.md"
+      - "**.txt"
+      - ".git*"
+      - "doc/**"
+      - "emacs/**"
+      - "vim/**"
+      - "**/emacs-lint.yml"
   pull_request:
-    branches: [ '414' ]
+    branches: ["414"]
     paths-ignore:
-      - '**.md'
-      - '**.txt'
-      - '.git*'
-      - 'doc/**'
-      - 'emacs/**'
-      - 'vim/**'
-      - '**/emacs-lint.yml'
+      - "**.md"
+      - "**.txt"
+      - ".git*"
+      - "doc/**"
+      - "emacs/**"
+      - "vim/**"
+      - "**/emacs-lint.yml"
   schedule:
-    - cron: '0 12 */6 * *'
+    - cron: "0 12 */6 * *"
 
 # A workflow run is made up of one or more jobs that can run sequentially or in parallel
 jobs:
@@ -53,7 +53,7 @@ jobs:
       - uses: actions/checkout@v3
 
       - 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 }}
@@ -82,9 +82,8 @@ jobs:
           opam exec -- dune build
           git diff --exit-code
 
-
       - name: Check that the changes are correctly formatted
         if: matrix.os == 'ubuntu-latest'
         run: |
-          opam install ocamlformat.0.26.2
+          opam install ocamlformat.0.27.0
           opam exec -- dune build @fmt

.github/workflows/ocaml-lsp-compat.yml

@@ -4,25 +4,25 @@ name: Check ocaml-lsp compat
 # events but only for the master branch
 on:
   push:
-    branches: [ master ]
+    branches: [master]
     paths-ignore:
-      - '**.md'
-      - '**.txt'
-      - '.git*'
-      - 'doc/**'
-      - 'emacs/**'
-      - 'vim/**'
-      - '**/emacs-lint.yml'
+      - "**.md"
+      - "**.txt"
+      - ".git*"
+      - "doc/**"
+      - "emacs/**"
+      - "vim/**"
+      - "**/emacs-lint.yml"
   pull_request:
-    branches: [ master ]
+    branches: [master]
     paths-ignore:
-      - '**.md'
-      - '**.txt'
-      - '.git*'
-      - 'doc/**'
-      - 'emacs/**'
-      - 'vim/**'
-      - '**/emacs-lint.yml'
+      - "**.md"
+      - "**.txt"
+      - ".git*"
+      - "doc/**"
+      - "emacs/**"
+      - "vim/**"
+      - "**/emacs-lint.yml"
 
 # A workflow run is made up of one or more jobs that can run sequentially or in parallel
 jobs:
@@ -55,4 +55,3 @@ jobs:
           opam --cli=2.1 pin --with-version=dev --no-action https://github.com/ocaml/ocaml-lsp.git
           opam --cli=2.1 pin --with-version=dev --no-action .
           opam install ocaml-lsp-server --with-test --ignore-constraints-on=merlin-lib
-

.ocamlformat

@@ -1,4 +1,4 @@
-version=0.26.2
+version=0.27.0
 disable=false
 
 break-cases=fit-or-vertical
@@ -8,4 +8,4 @@ dock-collection-brackets=false
 # Preserve begin/end
 exp-grouping=preserve
 module-item-spacing=preserve
-parse-docstrings=false
+parse-docstrings=false

CHANGES.md

@@ -1,3 +1,19 @@
+merlin 4.19
+===========
+Mon Jun 23 10:10:42 CEST 2024
+
+  + merlin library
+    - Expose utilities to manipulate typed-holes in `Merlin_analysis.Typed_hole`
+      (#1888)
+    - `inlay-hints` fix inlay hints on function parameters (#1923)
+    - Handle class type in outline (#1932)
+    - Handle locally defined value in outline (#1936)
+  + vim plugin
+    - Added support for search-by-type (#1846)
+      This is exposed through the existing `:MerlinSearch` command, that
+      switches between search-by-type and polarity search depending on the
+      first character of the query.
+
 merlin 4.18
 ===========
 Tue Nov 26 17:30:42 CET 2024

merlin-lib.opam

@@ -5,6 +5,7 @@ homepage:     "https://github.com/ocaml/merlin"
 bug-reports:  "https://github.com/ocaml/merlin/issues"
 dev-repo:     "git+https://github.com/ocaml/merlin.git"
 license:      "MIT"
+x-maintenance-intent: ["(latest)"]
 build: [
   ["dune" "subst"] {dev}
   ["dune" "build" "-p" name "-j" jobs]

merlin.opam

@@ -5,6 +5,7 @@ homepage:     "https://github.com/ocaml/merlin"
 bug-reports:  "https://github.com/ocaml/merlin/issues"
 dev-repo:     "git+https://github.com/ocaml/merlin.git"
 license:      "MIT"
+x-maintenance-intent: ["(latest)"]
 build: [
   ["dune" "subst"] {dev}
   ["dune" "build" "-p" name "-j" jobs]

src/analysis/completion.ml

@@ -507,7 +507,10 @@ let complete_methods ~env ~prefix obj =
   in
   let methods = List.filter ~f:has_prefix (methods_of_type env t) in
   List.map methods ~f:(fun (name, ty) ->
-      let info = `None (* TODO: get documentation. *) in
+      let info =
+        `None
+        (* TODO: get documentation. *)
+      in
       { name;
         kind = `MethodCall;
         desc = `Type_scheme ty;

src/analysis/destruct.ml

@@ -196,8 +196,8 @@ let rec needs_parentheses = function
          binding. *)
       | Texp_function { cases = [ _ ]; _ }
       (* The assumption here is that we're not in a [function ... | ...]
-          situation but either in [fun param] or [let name param]. *) ->
-        needs_parentheses ts
+          situation but either in [fun param] or [let name param]. *)
+        -> needs_parentheses ts
       | _ -> true
     end
     | _ -> needs_parentheses ts)

src/analysis/inlay_hints.ml

@@ -17,7 +17,7 @@ let pattern_has_constraint (type a) (pattern : a Typedtree.general_pattern) =
     pattern.pat_extra
 
 let structure_iterator hint_let_binding hint_pattern_binding
-    avoid_ghost_location typedtree range callback =
+    _hint_function_params avoid_ghost_location typedtree range callback =
   let case_iterator hint_lhs (iterator : Iterator.iterator) case =
     let () = log ~title:"case" "on case" in
     let () = if hint_lhs then iterator.pat iterator case.Typedtree.c_lhs in
@@ -136,21 +136,24 @@ let create_hint env typ loc =
   let position = loc.Location.loc_end in
   (position, label)
 
-let of_structure ~hint_let_binding ~hint_pattern_binding ~avoid_ghost_location
-    ~start ~stop structure =
+let of_structure ~hint_let_binding ~hint_pattern_binding ~hint_function_params
+    ~avoid_ghost_location ~start ~stop structure =
   let () =
     log ~title:"start" "%a" Logger.fmt (fun fmt ->
         Format.fprintf fmt
-          "Start on %s to %s with : let: %b, pat: %b, ghost: %b"
+          "Start on %s to %s with : let: %b, pat: %b, function_param: %b, \
+           ghost: %b"
           (Lexing.print_position () start)
           (Lexing.print_position () stop)
-          hint_let_binding hint_pattern_binding avoid_ghost_location)
+          hint_let_binding hint_pattern_binding hint_function_params
+          avoid_ghost_location)
   in
   let range = (start, stop) in
   let hints = ref [] in
   let () =
     structure_iterator hint_let_binding hint_pattern_binding
-      avoid_ghost_location structure range (fun env typ loc ->
+      hint_function_params avoid_ghost_location structure range
+      (fun env typ loc ->
         let () =
           log ~title:"hint" "Find hint %a" Logger.fmt (fun fmt ->
               Format.fprintf fmt "%s - %a"

src/analysis/inlay_hints.mli

@@ -5,6 +5,7 @@ type hint = Lexing.position * string
 val of_structure :
   hint_let_binding:bool ->
   hint_pattern_binding:bool ->
+  hint_function_params:bool ->
   avoid_ghost_location:bool ->
   start:Lexing.position ->
   stop:Lexing.position ->

src/analysis/locate.ml

@@ -888,15 +888,15 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid =
         | Interface s ->
           Some
             (`Interface
-              { s with
-                sig_final_env = Envaux.env_of_only_summary s.sig_final_env
-              })
+               { s with
+                 sig_final_env = Envaux.env_of_only_summary s.sig_final_env
+               })
         | Implementation str ->
           Some
             (`Implementation
-              { str with
-                str_final_env = Envaux.env_of_only_summary str.str_final_env
-              })
+               { str with
+                 str_final_env = Envaux.env_of_only_summary str.str_final_env
+               })
         | _ -> None
       end
     | Error _ -> None
@@ -946,7 +946,8 @@ let doc_from_uid ~config ~loc uid =
       when Env.get_unit_name () <> comp_unit -> (
       log ~title:"get_doc"
         "the doc (%a) you're looking for is in another\n\
-        \          compilation unit (%s)" Logger.fmt
+        \          compilation unit (%s)"
+        Logger.fmt
         (fun fmt -> Shape.Uid.print fmt uid)
         comp_unit;
       match find_doc_attributes_in_typedtree ~config ~comp_unit uid with

src/analysis/outline.ml

@@ -48,9 +48,9 @@ let mk ?(children = []) ~location ~deprecated outline_kind outline_type id =
     deprecated
   }
 
-let get_class_field_desc_infos = function
-  | Typedtree.Tcf_val (str_loc, _, _, _, _) -> Some (str_loc, `Value)
-  | Typedtree.Tcf_method (str_loc, _, _) -> Some (str_loc, `Method)
+let get_class_signature_field_desc_infos = function
+  | Typedtree.Tctf_val (outline_name, _, _, _) -> Some (outline_name, `Value)
+  | Typedtree.Tctf_method (outline_name, _, _, _) -> Some (outline_name, `Method)
   | _ -> None
 
 let outline_type ~env typ =
@@ -64,13 +64,16 @@ let rec summarize node =
   let location = node.t_loc in
   match node.t_node with
   | Value_binding vb ->
+    let children =
+      List.concat_map (Lazy.force node.t_children) ~f:get_val_elements
+    in
     let deprecated = Type_utils.is_deprecated vb.vb_attributes in
     begin
       match id_of_patt vb.vb_pat with
       | None -> None
       | Some ident ->
         let typ = outline_type ~env:node.t_env vb.vb_pat.pat_type in
-        Some (mk ~location ~deprecated `Value typ ident)
+        Some (mk ~children ~location ~deprecated `Value typ ident)
     end
   | Value_description vd ->
     let deprecated = Type_utils.is_deprecated vd.val_attributes in
@@ -141,32 +144,65 @@ let rec summarize node =
     in
     let deprecated = Type_utils.is_deprecated cd.ci_attributes in
     Some (mk ~children ~location `Class None cd.ci_id_class_type ~deprecated)
+  | Class_type_declaration ctd ->
+    let children =
+      List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+    in
+    let deprecated = Type_utils.is_deprecated ctd.ci_attributes in
+    Some
+      (mk ~children ~location `ClassType None ctd.ci_id_class_type ~deprecated)
   | _ -> None
 
+and get_val_elements node =
+  match node.t_node with
+  | Expression _ ->
+    List.concat_map (Lazy.force node.t_children) ~f:get_val_elements
+  | Class_expr _ | Class_structure _ -> get_class_elements node
+  | _ -> Option.to_list (summarize node)
+
 and get_class_elements node =
   match node.t_node with
   | Class_expr _ ->
     List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+  | Class_field cf ->
+    let children =
+      List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+    in
+    cf.cf_desc |> get_class_field_desc_infos
+    |> Option.map ~f:(fun (str_loc, outline_kind) ->
+           let deprecated = Type_utils.is_deprecated cf.cf_attributes in
+           { Query_protocol.outline_name = str_loc.Location.txt;
+             outline_kind;
+             outline_type = None;
+             location = str_loc.Location.loc;
+             children;
+             deprecated
+           })
+    |> Option.to_list
+  | Class_field_kind _ ->
+    List.concat_map (Lazy.force node.t_children) ~f:get_val_elements
   | Class_structure _ ->
-    List.filter_map (Lazy.force node.t_children) ~f:(fun child ->
-        match child.t_node with
-        | Class_field cf -> begin
-          match get_class_field_desc_infos cf.cf_desc with
-          | Some (str_loc, outline_kind) ->
-            let deprecated = Type_utils.is_deprecated cf.cf_attributes in
-            Some
-              { Query_protocol.outline_name = str_loc.Location.txt;
-                outline_kind;
-                outline_type = None;
-                location = str_loc.Location.loc;
-                children = [];
-                deprecated
-              }
-          | None -> None
-        end
-        | _ -> None)
+    List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+  | Class_type { cltyp_desc = Tcty_signature { csig_fields; _ }; _ } ->
+    List.filter_map csig_fields ~f:(fun field ->
+        get_class_signature_field_desc_infos field.ctf_desc
+        |> Option.map ~f:(fun (name, outline_kind) ->
+               let deprecated = Type_utils.is_deprecated field.ctf_attributes in
+               { Query_protocol.outline_name = name;
+                 outline_kind;
+                 outline_type = None;
+                 location = field.ctf_loc;
+                 (* TODO: could we have more precised location information? *)
+                 children = [];
+                 deprecated
+               }))
   | _ -> []
 
+and get_class_field_desc_infos = function
+  | Typedtree.Tcf_val (str_loc, _, _, _field_kind, _) -> Some (str_loc, `Value)
+  | Typedtree.Tcf_method (str_loc, _, _field_kind) -> Some (str_loc, `Method)
+  | _ -> None
+
 and get_mod_children node =
   List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir
 

src/analysis/syntax_doc.ml

@@ -39,7 +39,7 @@ let get_syntax_doc cursor_loc node : syntax_info =
     :: ( _,
          Module_type_constraint
            (Tmodtype_explicit
-             { mty_desc = Tmty_with (_, [ (_, _, Twith_modtype _) ]); _ }) )
+              { mty_desc = Tmty_with (_, [ (_, _, Twith_modtype _) ]); _ }) )
     :: _ ->
     Some
       { name = "Module substitution";

src/analysis/tail_analysis.ml

@@ -75,7 +75,7 @@ let expr_tail_positions = function
   | Texp_unreachable
   | Texp_extension_constructor _
   | Texp_letop _
-  | Texp_hole -> []
+  | Texp_typed_hole -> []
   | Texp_match (_, cs, _) -> List.map cs ~f:(fun c -> Case c)
   | Texp_try (_, cs) -> List.map cs ~f:(fun c -> Case c)
   | Texp_letmodule (_, _, _, _, e)