Support project wide occurrences

.github/workflows/build-and-test.yml

@@ -18,18 +18,8 @@ jobs:
       matrix:
         os:
           - ubuntu-latest
-        ocaml-compiler:
-          - "4.14"
-          - "5.0"
-          - "5.1"
-        include:
-          - os: macos-latest
-            ocaml-compiler: "4.14"
-          - os: windows-latest
-            ocaml-compiler: "4.14"
-            opam-repositories: |
-              opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset
-              default: https://github.com/ocaml/opam-repository.git
+          - macos-latest
+          - windows-latest
 
     runs-on: ${{ matrix.os }}
 
@@ -53,12 +43,10 @@ jobs:
         run: yarn --frozen-lockfile
         working-directory: ocaml-lsp-server/test/e2e
 
-      - name: Set-up OCaml ${{ matrix.ocaml-compiler }}
+      - name: Set-up OCaml
         uses: ocaml/setup-ocaml@v2
         with:
-          ocaml-compiler: ${{ matrix.ocaml-compiler }}
-          allow-prerelease-opam: true
-          opam-repositories: ${{ matrix.opam-repositories }}
+          ocaml-compiler: "5.2"
 
       - name: Build and install dependencies
         run: opam install .
@@ -67,19 +55,15 @@ jobs:
       # ppx expect is not yet compatible with 5.1 and test output vary from one
       # compiler to another. We only test on 4.14.
       - name: Install test dependencies
-        if: matrix.ocaml-compiler == '4.14'
         run: opam exec -- make install-test-deps
 
       - name: Run build @all
-        if: matrix.ocaml-compiler == '4.14'
         run: opam exec -- make all
 
       - name: Run the unit tests
-        if: matrix.ocaml-compiler == '4.14'
         run: opam exec -- make test-ocaml
 
       - name: Run the template integration tests
-        if: matrix.ocaml-compiler == '4.14'
         run: opam exec -- make test-e2e
 
   coverage:
@@ -94,7 +78,7 @@ jobs:
       - name: Set-up OCaml
         uses: ocaml/setup-ocaml@v2
         with:
-          ocaml-compiler: "4.14"
+          ocaml-compiler: "5.2"
           allow-prerelease-opam: true
 
       - name: Set git user

dune-project

@@ -60,14 +60,13 @@ possible and does not make any assumptions about IO.
   astring
   camlp-streams
   (ppx_expect (and (>= v0.15.0) :with-test))
-  (ocamlformat (and :with-test (= 0.24.1)))
+  (ocamlformat (and :with-test (= 0.26.1)))
   (ocamlc-loc (>= 3.7.0))
   (pp (>= 1.1.2))
   (csexp (>= 1.5))
   (ocamlformat-rpc-lib (>= 0.21.0))
   (odoc :with-doc)
-  (ocaml (and (>= 4.14) (< 5.2)))
-  (merlin-lib (and (>= 4.14) (< 5.0)))))
+  (merlin-lib (and (>= 5.0) (< 6.0)))))
 
 (package
  (name jsonrpc)

ocaml-lsp-server.opam

@@ -36,14 +36,13 @@ depends: [
   "astring"
   "camlp-streams"
   "ppx_expect" {>= "v0.15.0" & with-test}
-  "ocamlformat" {with-test & = "0.24.1"}
+  "ocamlformat" {with-test & = "0.26.1"}
   "ocamlc-loc" {>= "3.7.0"}
   "pp" {>= "1.1.2"}
   "csexp" {>= "1.5"}
   "ocamlformat-rpc-lib" {>= "0.21.0"}
   "odoc" {with-doc}
-  "ocaml" {>= "4.14" & < "5.2"}
-  "merlin-lib" {>= "4.14" & < "5.0"}
+  "merlin-lib" {>= "5.0" & < "6.0"}
 ]
 dev-repo: "git+https://github.com/ocaml/ocaml-lsp.git"
 build: [

ocaml-lsp-server/src/code_actions/action_add_rec.ml

@@ -6,7 +6,7 @@ let action_title = "Add missing `rec` keyword"
 let let_bound_vars bindings =
   List.filter_map bindings ~f:(fun vb ->
       match vb.Typedtree.vb_pat.pat_desc with
-      | Typedtree.Tpat_var (id, loc) -> Some (id, loc)
+      | Typedtree.Tpat_var (id, loc, _) -> Some (id, loc)
       | _ -> None)
 
 (** If the cursor position is inside a let binding which should have a ret tag

ocaml-lsp-server/src/code_actions/action_extract.ml

@@ -69,7 +69,8 @@ let tightest_enclosing_binder_position typedtree range =
       | Texp_letexception (_, body)
       | Texp_open (_, body) -> found_if_expr_contains body
       | Texp_letop { body; _ } -> found_if_case_contains [ body ]
-      | Texp_function { cases; _ } -> found_if_case_contains cases
+      | Texp_function (_, Tfunction_cases { cases; _ }) ->
+        found_if_case_contains cases
       | Texp_match (_, cases, _) -> found_if_case_contains cases
       | Texp_try (_, cases) -> found_if_case_contains cases
       | _ -> ())

ocaml-lsp-server/src/code_actions/action_inline.ml

@@ -63,7 +63,7 @@ let find_inline_task typedtree pos =
       match expr.exp_desc with
       | Texp_let
           ( Nonrecursive
-          , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }); _ }
+          , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }, _); _ }
               ; vb_expr = inlined_expr
               ; _
               }
@@ -79,7 +79,7 @@ let find_inline_task typedtree pos =
       match item.str_desc with
       | Tstr_value
           ( Nonrecursive
-          , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }); _ }
+          , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }, _); _ }
               ; vb_expr = inlined_expr
               ; _
               }
@@ -132,45 +132,11 @@ let strip_attribute attr_name expr =
   let mapper = { M.default_mapper with expr = expr_map } in
   mapper.expr mapper expr
 
-(** Overapproximation of the number of uses of a [Path.t] in an expression. *)
-module Uses : sig
-  type t
-
-  val find : t -> Path.t -> int option
-
-  val of_typedtree : Typedtree.expression -> t
-end = struct
-  type t = int Path.Map.t
-
-  let find m k = Path.Map.find_opt k m
-
-  let of_typedtree (expr : Typedtree.expression) =
-    let module I = Ocaml_typing.Tast_iterator in
-    let uses = ref Path.Map.empty in
-    let expr_iter (iter : I.iterator) (expr : Typedtree.expression) =
-      match expr.exp_desc with
-      | Texp_ident (path, _, _) ->
-        uses :=
-          Path.Map.update
-            path
-            (function
-              | Some c -> Some (c + 1)
-              | None -> Some 1)
-            !uses
-      | _ -> I.default_iterator.expr iter expr
-    in
-    let iterator = { I.default_iterator with expr = expr_iter } in
-    iterator.expr iterator expr;
-    !uses
-end
-
 (** Mapping from [Location.t] to [Path.t]. Computed from the typedtree. Useful
     for determining whether two parsetree identifiers refer to the same path. *)
 module Paths : sig
   type t
 
-  val find : t -> Loc.t -> Path.t option
-
   val of_typedtree : Typedtree.expression -> t
 
   val same_path : t -> Loc.t -> Loc.t -> bool
@@ -190,8 +156,9 @@ end = struct
     let pat_iter (type k) (iter : I.iterator)
         (pat : k Typedtree.general_pattern) =
       match pat.pat_desc with
-      | Tpat_var (id, { loc; _ }) -> paths := Loc.Map.set !paths loc (Pident id)
-      | Tpat_alias (pat, id, { loc; _ }) ->
+      | Tpat_var (id, { loc; _ }, _) ->
+        paths := Loc.Map.set !paths loc (Pident id)
+      | Tpat_alias (pat, id, { loc; _ }, _) ->
         paths := Loc.Map.set !paths loc (Pident id);
         I.default_iterator.pat iter pat
       | _ -> I.default_iterator.pat iter pat
@@ -219,82 +186,59 @@ let subst same subst_expr subst_id body =
   mapper.expr mapper body
 
 (** Rough check for expressions that can be duplicated without duplicating any
-    side effects. *)
+    side effects (or introducing a sigificant performance difference). *)
 let rec is_pure (expr : Parsetree.expression) =
   match expr.pexp_desc with
   | Pexp_ident _ | Pexp_constant _ | Pexp_unreachable -> true
   | Pexp_field (e, _) | Pexp_constraint (e, _) -> is_pure e
   | _ -> false
 
-let rec find_map_remove ~f = function
-  | [] -> (None, [])
-  | x :: xs -> (
-    match f x with
-    | Some x' -> (Some x', xs)
-    | None ->
-      let ret, xs' = find_map_remove ~f xs in
-      (ret, x :: xs'))
+let all_unlabeled_params =
+  List.for_all ~f:(fun p ->
+      match p.Parsetree.pparam_desc with
+      | Pparam_val (Nolabel, _, _) -> true
+      | _ -> false)
 
-let rec beta_reduce (uses : Uses.t) (paths : Paths.t)
-    (app : Parsetree.expression) =
-  let rec beta_reduce_arg (pat : Parsetree.pattern) body arg =
-    let default () =
-      H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body)
-    in
+let same_path paths (id : _ H.with_loc) (id' : _ H.with_loc) =
+  Paths.same_path paths id.loc id'.loc
+
+let beta_reduce (paths : Paths.t) (app : Parsetree.expression) =
+  let rec beta_reduce_arg body (pat : Parsetree.pattern) arg =
+    let with_let () = H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] body in
+    let with_subst param = subst (same_path paths) arg param body in
     match pat.ppat_desc with
     | Ppat_any | Ppat_construct ({ txt = Lident "()"; _ }, _) ->
-      beta_reduce uses paths body
-    | Ppat_var param | Ppat_constraint ({ ppat_desc = Ppat_var param; _ }, _)
-      -> (
-      let open Option.O in
-      let m_uses =
-        let* path = Paths.find paths param.loc in
-        Uses.find uses path
-      in
-      let same_path paths (id : _ H.with_loc) (id' : _ H.with_loc) =
-        Paths.same_path paths id.loc id'.loc
-      in
-      match m_uses with
-      | Some 0 -> beta_reduce uses paths body
-      | Some 1 ->
-        beta_reduce uses paths (subst (same_path paths) arg param body)
-      | Some _ | None ->
-        if is_pure arg then
-          beta_reduce uses paths (subst (same_path paths) arg param body)
-        else
-          (* if the parameter is used multiple times in the body, introduce a
-             let binding so that the parameter is evaluated only once *)
-          default ())
+      if is_pure arg then body else with_let ()
+    | Ppat_var param | Ppat_constraint ({ ppat_desc = Ppat_var param; _ }, _) ->
+      if is_pure arg then with_subst param else with_let ()
     | Ppat_tuple pats -> (
       match arg.pexp_desc with
       | Pexp_tuple args ->
-        List.fold_left2
-          ~f:(fun body pat arg -> beta_reduce_arg pat body arg)
-          ~init:body
-          pats
-          args
-      | _ -> default ())
-    | _ -> default ()
+        List.fold_left2 ~f:beta_reduce_arg ~init:body pats args
+      | _ -> with_let ())
+    | _ -> with_let ()
   in
-  let apply func args =
-    if List.is_empty args then func else H.Exp.apply func args
+  let extract_param_pats params =
+    List.map params ~f:(fun p ->
+        match p.Parsetree.pparam_desc with
+        | Pparam_val (Nolabel, _, pat) -> Some pat
+        | _ -> None)
+    |> Option.List.all
   in
   match app.pexp_desc with
   | Pexp_apply
-      ( { pexp_desc = Pexp_fun (Nolabel, None, pat, body); _ }
-      , (Nolabel, arg) :: args' ) -> beta_reduce_arg pat (apply body args') arg
-  | Pexp_apply
-      ({ pexp_desc = Pexp_fun ((Labelled l as lbl), None, pat, body); _ }, args)
+      ( { pexp_desc = Pexp_function (params, None, Pfunction_body body); _ }
+      , args )
+    when List.length params = List.length args && all_unlabeled_params params
     -> (
-    let m_matching_arg, args' =
-      find_map_remove args ~f:(function
-          | Asttypes.Labelled l', e when String.equal l l' -> Some e
-          | _ -> None)
-    in
-    match m_matching_arg with
-    | Some arg -> beta_reduce_arg pat (apply body args') arg
-    | None -> H.Exp.fun_ lbl None pat (beta_reduce uses paths (apply body args))
-    )
+    match extract_param_pats params with
+    | Some pats ->
+      List.fold_left2
+        ~f:(fun body pat (_, arg) -> beta_reduce_arg body pat arg)
+        ~init:body
+        pats
+        args
+    | None -> app)
   | _ -> app
 
 let inlined_text pipeline task =
@@ -358,7 +302,6 @@ let inline_edits pipeline task =
     | _, _ -> Option.iter m_arg_expr ~f:(iter.expr iter)
   in
 
-  let uses = Uses.of_typedtree task.inlined_expr in
   let paths = Paths.of_typedtree task.inlined_expr in
   let inlined_pexpr =
     find_parsetree_loc_exn pipeline task.inlined_expr.exp_loc
@@ -374,7 +317,7 @@ let inline_edits pipeline task =
         let app_pexpr = find_parsetree_loc_exn pipeline expr.exp_loc in
         match app_pexpr.pexp_desc with
         | Pexp_apply ({ pexp_desc = Pexp_ident _; _ }, args) ->
-          beta_reduce uses paths (H.Exp.apply inlined_pexpr args)
+          beta_reduce paths (H.Exp.apply inlined_pexpr args)
         | _ -> app_pexpr
       in
       let newText =

ocaml-lsp-server/src/code_actions/action_mark_remove_unused.ml

@@ -67,7 +67,7 @@ let rec mark_value_unused_edit name contexts =
           (function
            | ( { loc = field_loc; _ }
              , _
-             , { pat_desc = Tpat_var (ident, _); pat_loc; _ } )
+             , { pat_desc = Tpat_var (ident, _, _); pat_loc; _ } )
              when Ident.name ident = name ->
              (* Special case for record shorthand *)
              if
@@ -96,7 +96,7 @@ let rec mark_value_unused_edit name contexts =
     match m_field_edit with
     | Some e -> Some e
     | None -> mark_value_unused_edit name cs)
-  | Pattern { pat_desc = Tpat_var (ident, _); pat_loc = loc; _ } :: _ ->
+  | Pattern { pat_desc = Tpat_var (ident, _, _); pat_loc = loc; _ } :: _ ->
     if Ident.name ident = name then
       let+ start = Position.of_lexical_position loc.loc_start in
       { TextEdit.range = Range.create ~start ~end_:start; newText = "_" }
@@ -130,7 +130,7 @@ let enclosing_value_binding_range name =
               Texp_let
                 ( _
                 , [ { vb_pat =
-                        { pat_desc = Tpat_var (_, { txt = name'; _ }); _ }
+                        { pat_desc = Tpat_var (_, { txt = name'; _ }, _); _ }
                     ; _
                     }
                   ]

ocaml-lsp-server/src/document_symbol.ml

@@ -173,7 +173,7 @@ let binding_document_symbol (binding : Parsetree.value_binding) ~ppx
   | `Parent name ->
     let kind : SymbolKind.t =
       match (ppx, binding.pvb_expr.pexp_desc) with
-      | None, (Pexp_function _ | Pexp_fun _ | Pexp_newtype _) -> Function
+      | None, (Pexp_function _ | Pexp_newtype _) -> Function
       | Some _, _ -> Property
       | _ -> Variable
     in

ocaml-lsp-server/src/folding_range.ml

@@ -206,11 +206,9 @@ let fold_over_parsetree (parsetree : Mreader.parsetree) =
       | Pexp_extension _
       | Pexp_let _
       | Pexp_open _
-      | Pexp_fun _
       | Pexp_poly _
       | Pexp_sequence _
       | Pexp_constraint _
-      | Pexp_function _
       | Pexp_newtype _
       | Pexp_lazy _
       | Pexp_letexception _
@@ -228,7 +226,8 @@ let fold_over_parsetree (parsetree : Mreader.parsetree) =
       | Pexp_setinstvar _
       | Pexp_override _
       | Pexp_assert _
-      | Pexp_unreachable -> Ast_iterator.default_iterator.expr self expr
+      | Pexp_unreachable
+      | _ -> Ast_iterator.default_iterator.expr self expr
     in
 
     let module_binding (self : Ast_iterator.iterator)