Revert "Compatibility with merlin-lib 5.1-502 (ocaml#1233)"

This reverts commit 4e74156.

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

@@ -21,8 +21,10 @@ jobs:
           - macos-latest
           - windows-latest
         ocaml-compiler:
-          - "5.2"
-
+          - "4.14"
+        include:
+          - os: ubuntu-latest
+            ocaml-compiler: 5.1.x
 
     runs-on: ${{ matrix.os }}
 
@@ -63,15 +65,19 @@ 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:
@@ -86,7 +92,7 @@ jobs:
       - name: Set-up OCaml
         uses: ocaml/setup-ocaml@v2
         with:
-          ocaml-compiler: "5.2"
+          ocaml-compiler: "4.14"
           allow-prerelease-opam: true
 
       - name: Set git user

Makefile

@@ -17,7 +17,7 @@ all:
 # results in a conflict
 .PHONY: install-test-deps
 install-test-deps:
-	opam install --yes cinaps 'ppx_expect>=v0.17.0' \
+	opam install --yes cinaps 'ppx_expect<v0.17.0' \
 		ocamlformat.$$(awk -F = '$$1 == "version" {print $$2}' .ocamlformat)
 
 .PHONY: dev

flake.nix

@@ -137,12 +137,28 @@
             overlays = [ (ocamlVersionOverlay ocaml) (overlay merlin) ];
             inherit system;
           };
+<<<<<<< HEAD
         pkgs_5_1 =
           makeNixpkgs (ocaml: ocaml.ocamlPackages_5_1) inputs.merlin5_1;
         pkgs_5_2 =
           makeNixpkgs (ocaml: ocaml.ocamlPackages_5_2) inputs.merlin5_2;
         localPackages_5_1 = makeLocalPackages pkgs_5_1;
         localPackages_5_2 = makeLocalPackages pkgs_5_2;
+||||||| 4e741568 (Compatibility with merlin-lib 5.1-502 (#1233))
+        pkgs_4_14 =
+          makeNixpkgs (ocaml: ocaml.ocamlPackages_4_14) inputs.merlin4_14;
+        pkgs_5_2 =
+          makeNixpkgs (ocaml: ocaml.ocamlPackages_5_2) inputs.merlin5_2;
+        localPackages_4_14 = makeLocalPackages pkgs_4_14;
+        localPackages_5_2 = makeLocalPackages pkgs_5_2;
+=======
+        pkgs_4_14 =
+          makeNixpkgs (ocaml: ocaml.ocamlPackages_4_14) inputs.merlin4_14;
+        pkgs_5_1 =
+          makeNixpkgs (ocaml: ocaml.ocamlPackages_5_1) inputs.merlin5_1;
+        localPackages_4_14 = makeLocalPackages pkgs_4_14;
+        localPackages_5_1 = makeLocalPackages pkgs_5_1;
+>>>>>>> parent of 4e741568 (Compatibility with merlin-lib 5.1-502 (#1233))
         devShell = localPackages: nixpkgs:
           nixpkgs.mkShell {
             buildInputs = [ nixpkgs.ocamlPackages.utop ];
@@ -151,13 +167,31 @@
               (builtins.attrValues localPackages);
           };
       in {
+<<<<<<< HEAD
         packages = (localPackages_5_2 // {
           default = localPackages_5_2.ocaml-lsp;
           ocaml_5_1 = localPackages_5_1;
         });
+||||||| 4e741568 (Compatibility with merlin-lib 5.1-502 (#1233))
+        packages =
+          (localPackages_5_2 // { default = localPackages_5_2.ocaml-lsp; });
+=======
+        packages =
+          (localPackages_4_14 // { default = localPackages_4_14.ocaml-lsp; });
+>>>>>>> parent of 4e741568 (Compatibility with merlin-lib 5.1-502 (#1233))
 
         devShells = {
+<<<<<<< HEAD
+          default = devShell localPackages_5_2 pkgs_5_2;
+||||||| 4e741568 (Compatibility with merlin-lib 5.1-502 (#1233))
+          ocaml4_11 = devShell localPackages_4_14 pkgs_4_14;
+
           default = devShell localPackages_5_2 pkgs_5_2;
+=======
+          default = devShell localPackages_4_14 pkgs_4_14;
+
+          ocaml5_1 = devShell localPackages_5_1 pkgs_5_1;
+>>>>>>> parent of 4e741568 (Compatibility with merlin-lib 5.1-502 (#1233))
 
           ocaml5_1 = devShell localPackages_5_1 pkgs_5_1;
 
@@ -176,8 +210,8 @@
             ];
           };
 
-          check = pkgs_5_2.mkShell {
-            inputsFrom = builtins.attrValues localPackages_5_2;
+          check = pkgs_4_14.mkShell {
+            inputsFrom = builtins.attrValues localPackages_4_14;
           };
         };
       }));

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)
 ;;
 

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

@@ -74,7 +74,7 @@ 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 (_, Tfunction_cases { cases; _ }) -> found_if_case_contains cases
+      | Texp_function { 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

@@ -66,7 +66,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
               ; _
               }
@@ -81,7 +81,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
               ; _
               }
@@ -137,11 +137,44 @@ let strip_attribute attr_name expr =
   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
 end = struct
@@ -159,8 +192,8 @@ end = struct
     in
     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
@@ -189,58 +222,77 @@ let subst same subst_expr subst_id body =
 ;;
 
 (** Rough check for expressions that can be duplicated without duplicating any
-    side effects (or introducing a sigificant performance difference). *)
+    side effects. *)
 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 all_unlabeled_params =
-  List.for_all ~f:(fun p ->
-    match p.Parsetree.pparam_desc with
-    | Pparam_val (Nolabel, _, _) -> true
-    | _ -> false)
-;;
-
-let same_path paths (id : _ H.with_loc) (id' : _ H.with_loc) =
-  Paths.same_path paths id.loc id'.loc
+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 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
+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
     match pat.ppat_desc with
     | Ppat_any | Ppat_construct ({ txt = Lident "()"; _ }, _) ->
-      if is_pure arg then body else with_let ()
+      beta_reduce uses paths body
     | Ppat_var param | Ppat_constraint ({ ppat_desc = Ppat_var param; _ }, _) ->
-      if is_pure arg then with_subst param else with_let ()
+      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 ())
     | Ppat_tuple pats ->
       (match arg.pexp_desc with
-       | Pexp_tuple args -> List.fold_left2 ~f:beta_reduce_arg ~init:body pats args
-       | _ -> with_let ())
-    | _ -> with_let ()
-  in
-  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
+       | Pexp_tuple args ->
+         List.fold_left2
+           ~f:(fun body pat arg -> beta_reduce_arg pat body arg)
+           ~init:body
+           pats
+           args
+       | _ -> default ())
+    | _ -> default ()
   in
+  let apply func args = if List.is_empty args then func else H.Exp.apply func args in
   match app.pexp_desc with
-  | Pexp_apply ({ pexp_desc = Pexp_function (params, None, Pfunction_body body); _ }, args)
-    when List.length params = List.length args && all_unlabeled_params params ->
-    (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)
+  | 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)
+    ->
+    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)))
   | _ -> app
 ;;
 
@@ -302,6 +354,7 @@ let inline_edits pipeline task =
     | Optional _, Some _ -> ()
     | _, _ -> 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 in
   let expr_iter (iter : I.iterator) (expr : Typedtree.expression) =
@@ -314,7 +367,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 paths (H.Exp.apply inlined_pexpr args)
+          beta_reduce uses paths (H.Exp.apply inlined_pexpr args)
         | _ -> app_pexpr
       in
       let newText =

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

@@ -73,7 +73,7 @@ let rec mark_value_unused_edit name contexts =
         pats
         ~f:
           (function
-           | { loc = field_loc; _ }, _, { pat_desc = Tpat_var (ident, _, _); pat_loc; _ }
+           | { loc = field_loc; _ }, _, { pat_desc = Tpat_var (ident, _); pat_loc; _ }
              when Ident.name ident = name ->
              (* Special case for record shorthand *)
              if field_loc.loc_start = pat_loc.loc_start
@@ -95,7 +95,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
@@ -130,7 +130,7 @@ let enclosing_value_binding_range name =
         { exp_desc =
             Texp_let
               ( _
-              , [ { vb_pat = { pat_desc = Tpat_var (_, { txt = name'; _ }, _); _ }; _ } ]
+              , [ { vb_pat = { pat_desc = Tpat_var (_, { txt = name'; _ }); _ }; _ } ]
               , { exp_loc = { loc_start = let_end; _ }; _ } )
         ; exp_loc = { loc_start = let_start; _ }
         ; _

ocaml-lsp-server/src/document_symbol.ml

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

ocaml-lsp-server/src/folding_range.ml

@@ -196,6 +196,7 @@ let fold_over_parsetree (parsetree : Mreader.parsetree) =
       | Pexp_extension _
       | Pexp_let _
       | Pexp_open _
+      | Pexp_fun _
       | Pexp_poly _
       | Pexp_sequence _
       | Pexp_constraint _