Merge pull request #1850 from xvw/503-preview

Add support for 5.3.0

.github/workflows/main.yml

@@ -40,13 +40,13 @@ jobs:
           - ubuntu-latest
           - windows-latest
         ocaml-compiler:
-          - 5.2.x
+          - ocaml-base-compiler.5.3.0~beta2
     # The type of runner that the job will run on
     runs-on: ${{ matrix.os }}
 
     # Some tests requiring specific ppxes are disabled by default
     env:
-      MERLIN_TESTS: all
+      MERLIN_TESTS: no-ppx
 
     # Steps represent a sequence of tasks that will be executed as part of the job
     steps:
@@ -62,19 +62,12 @@ jobs:
       - name: Install dependencies
         run: |
           opam pin menhirLib 20201216 --no-action
-          opam install --yes ppx_string ppx_compare
-          opam install . --deps-only --with-test --yes
+          opam install menhir csexp alcotest yojson conf-jq ocamlfind --yes
 
-      - name: Build and test in release mode (windows)
-        if: matrix.os == 'windows-latest'
+      - name: Build and test in release mode
         run: |
           opam exec -- dune runtest -p merlin-lib,dot-merlin-reader,ocaml-index,merlin
 
-      - name: Build and test in release mode (macos/linux)
-        if: matrix.os != 'windows-latest'
-        run: |
-          opam install . --with-test --yes
-
       - name: Build in dev mode to check parser changes
         if: matrix.os == 'ubuntu-latest'
         run: |
@@ -84,7 +77,7 @@ jobs:
 
 
       - name: Check that the changes are correctly formatted
-        if: matrix.os == 'ubuntu-latest'
+        if: matrix.os == 'none'
         run: |
           opam install ocamlformat.0.26.2
           opam exec -- dune build @fmt

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

@@ -4,7 +4,7 @@ name: Check ocaml-lsp compat
 # events but only for the master branch
 on:
   push:
-    branches: [ master ]
+    branches: [ main ]
     paths-ignore:
       - '**.md'
       - '**.txt'
@@ -14,7 +14,7 @@ on:
       - 'vim/**'
       - '**/emacs-lint.yml'
   pull_request:
-    branches: [ master ]
+    branches: [ main ]
     paths-ignore:
       - '**.md'
       - '**.txt'
@@ -34,7 +34,7 @@ jobs:
         os:
           - ubuntu-latest
         ocaml-compiler:
-          - 5.2.x
+          - ocaml-base-compiler.5.3.0~alpha1
     # The type of runner that the job will run on
     runs-on: ${{ matrix.os }}
 
@@ -51,7 +51,7 @@ jobs:
 
       - name: Check that Merlin and OCaml-LSP are co-installable
         run: |
-          opam --cli=2.1 pin --with-version=dev --no-action https://github.com/voodoos/ocaml-lsp.git#5.2-preview
-          opam --cli=2.1 pin --with-version=5.0-502 --no-action .
-          opam install ocaml-lsp-server --with-test --ignore-constraints-on=ocamlformat
+          opam --cli=2.1 pin --with-version=dev --no-action https://github.com/voodoos/ocaml-lsp.git#merlin-503-compat
+          opam --cli=2.1 pin --with-version=5.3-503 --no-action .
+          opam install ocaml-lsp-server --ignore-constraints-on=ocamlformat
 

CHANGES.md

@@ -1,6 +1,8 @@
 unreleased
 ==========
 
+  + merlin binary
+    - Support for OCaml 5.3
   + vim plugin
     - Added support for search-by-type (#1846)
       This is exposed through the existing `:MerlinSearch` command, that

merlin-lib.opam

@@ -10,7 +10,7 @@ build: [
   ["dune" "build" "-p" name "-j" jobs]
 ]
 depends: [
-  "ocaml" {>= "5.2" & < "5.3"}
+  "ocaml" {>="5.3" & <"5.4"}
   "dune" {>= "3.0.0"}
   "csexp" {>= "1.5.1"}
   "alcotest" {with-test & >= "1.3.0" }

merlin.opam

@@ -11,7 +11,6 @@ build: [
   ["dune" "runtest" "-p" name "-j" jobs] {with-test}
 ]
 depends: [
-  "ocaml" {>= "5.2" & < "5.3"}
   "dune" {>= "3.0.0"}
   "merlin-lib" {= version}
   "dot-merlin-reader" {= version}
@@ -22,7 +21,6 @@ depends: [
 ]
 conflicts: [
   "seq" {!= "base"}
-  "base-effects"
 ]
 synopsis:
   "Editor helper, provides completion, typing and source browsing in Vim and Emacs"

src/analysis/ast_iterators.ml

@@ -133,8 +133,9 @@ let iter_on_defs ~uid_to_locs_tbl =
             match exp_extra with
             | Texp_newtype' (typ_id, typ_name, uid) ->
               log "Found newtype %s wit id %a (%a)\n%!" typ_name.txt Logger.fmt
-                (Fun.flip Ident.print_with_scope typ_id) Logger.fmt (fun fmt ->
-                  Location.print_loc fmt typ_name.loc);
+                (Fun.flip (Format_doc.compat Ident.print_with_scope) typ_id)
+                Logger.fmt
+                (fun fmt -> Location.print_loc fmt typ_name.loc);
               register_uid uid typ_name;
               ()
             | _ -> ());

src/analysis/construct.ml

@@ -37,26 +37,28 @@ module Util = struct
       let construct s =
         Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident s)) None
       in
+      let const_string str = Ast_helper.Const.string str in
+      let const_integer ?suffix str = Ast_helper.Const.integer ?suffix str in
+      let const_float ?suffix str = Ast_helper.Const.float ?suffix str in
+      let const_char c = Ast_helper.Const.char c in
       let ident s =
         Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident s))
       in
       List.iter
         ~f:(fun (k, v) -> Hashtbl.add tbl k v)
-        Parsetree.
-          [ (Predef.path_int, constant (Pconst_integer ("0", None)));
-            (Predef.path_float, constant (Pconst_float ("0.0", None)));
-            (Predef.path_char, constant (Pconst_char 'c'));
-            ( Predef.path_string,
-              constant (Pconst_string ("", Location.none, None)) );
-            (Predef.path_bool, construct "false");
-            (Predef.path_unit, construct "()");
-            (Predef.path_exn, ident "exn");
-            (Predef.path_array, Ast_helper.Exp.array []);
-            (Predef.path_nativeint, constant (Pconst_integer ("0", Some 'n')));
-            (Predef.path_int32, constant (Pconst_integer ("0", Some 'l')));
-            (Predef.path_int64, constant (Pconst_integer ("0", Some 'L')));
-            (Predef.path_lazy_t, Ast_helper.Exp.lazy_ (construct "()"))
-          ]
+        [ (Predef.path_int, constant (const_integer "0"));
+          (Predef.path_float, constant (const_float "0.0"));
+          (Predef.path_char, constant (const_char 'c'));
+          (Predef.path_string, constant (const_string ""));
+          (Predef.path_bool, construct "false");
+          (Predef.path_unit, construct "()");
+          (Predef.path_exn, ident "exn");
+          (Predef.path_array, Ast_helper.Exp.array []);
+          (Predef.path_nativeint, constant (const_integer ~suffix:'n' "0"));
+          (Predef.path_int32, constant (const_integer ~suffix:'l' "0"));
+          (Predef.path_int64, constant (const_integer ~suffix:'L' "0"));
+          (Predef.path_lazy_t, Ast_helper.Exp.lazy_ (construct "()"))
+        ]
     in
     tbl
 
@@ -495,7 +497,7 @@ module Gen = struct
                   val_kind = Val_reg;
                   val_loc = Location.none;
                   val_attributes = [];
-                  val_uid = Uid.mk ~current_unit:(Env.get_unit_name ())
+                  val_uid = Uid.mk ~current_unit:(Env.get_current_unit ())
                 }
               in
               let env =

src/analysis/context.ml

@@ -66,7 +66,8 @@ let cursor_on_longident_end ~cursor:cursor_pos
       (* FIXME: this is britle, but lids don't have precise enough location
          information to handle these cases correctly. *)
       let name_lenght = String.length name in
-      if Pprintast.needs_parens name then name_lenght + 2 else name_lenght
+      if Pprintast.needs_parens ~kind:Other name then name_lenght + 2
+      else name_lenght
     in
     let constr_pos =
       { loc.loc_end with pos_cnum = end_offset - cstr_name_size }

src/analysis/destruct.ml

@@ -214,7 +214,7 @@ let rec get_match = function
       get_match parents
     | Expression m -> (
       match m.Typedtree.exp_desc with
-      | Typedtree.Texp_match (e, _, _) -> (m, e.exp_type)
+      | Typedtree.Texp_match (e, _, _, _) -> (m, e.exp_type)
       | Typedtree.Texp_function _ -> (
         let typ = m.exp_type in
         (* Function must have arrow type. This arrow type

src/analysis/env_lookup.ml

@@ -96,7 +96,7 @@ let by_longident (nss : Namespace.inferred list) ident env =
               "got constructor, fetching path and loc in type namespace";
             let path, loc = path_and_loc_of_cstr cd env in
             log ~title:"lookup" "found path: %a" Logger.fmt (fun fmt ->
-                Path.print fmt path);
+                (Format_doc.compat Path.print) fmt path);
             let path = Path.Pdot (path, cd.cstr_name) in
             raise (Found (path, Constructor, cd.cstr_uid, loc))
           | `Constr ->
@@ -142,7 +142,7 @@ let by_longident (nss : Namespace.inferred list) ident env =
   with Found (path, namespace, decl_uid, loc) ->
     log ~title:"env_lookup"
       "found: '%a' in namespace %s with decl_uid %a\nat loc %a" Logger.fmt
-      (fun fmt -> Path.print fmt path)
+      (fun fmt -> (Format_doc.compat Path.print) fmt path)
       (Shape.Sig_component_kind.to_string namespace)
       Logger.fmt
       (fun fmt -> Shape.Uid.print fmt decl_uid)

src/analysis/index_occurrences.ml

@@ -28,7 +28,8 @@ let decl_of_path_or_lid env namespace path lid =
 let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
   let add uid loc = Stamped_hashtable.add index ~stamp (uid, loc) () in
   let f ~namespace env path (lid : Longident.t Location.loc) =
-    log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path);
+    log ~title:"index_buffer" "Path: %a" Logger.fmt
+      (Fun.flip (Format_doc.compat Path.print) path);
     let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
     let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in
     let index_decl () =

src/analysis/inlay_hints.ml

@@ -59,7 +59,7 @@ let structure_iterator hint_let_binding hint_pattern_binding
       | Texp_letop { body; _ } ->
         let () = log ~title:"expression" "on let-op" in
         case_iterator hint_let_binding iterator body
-      | Texp_match (expr, cases, _) ->
+      | Texp_match (expr, cases, _, _) ->
         let () = log ~title:"expression" "on match" in
         let () = iterator.expr iterator expr in
         List.iter ~f:(case_iterator hint_pattern_binding iterator) cases

src/analysis/jump.ml

@@ -119,7 +119,7 @@ let rec skip_non_moving pos = function
 
 let get_cases_from_match node =
   match node with
-  | Expression { exp_desc = Texp_match (_, cases, _); _ } -> cases
+  | Expression { exp_desc = Texp_match (_, cases, _, _); _ } -> cases
   | _ -> []
 
 let find_case_pos cases pos direction =

src/analysis/locate.ml

@@ -496,7 +496,7 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit =
       log ~title "The declaration has no location.";
       `None
   in
-  if Env.get_unit_name () = comp_unit then begin
+  if Env.get_current_unit_name () = comp_unit then begin
     log ~title "We look for %a in the current compilation unit." Logger.fmt
       (fun fmt -> Shape.Uid.print fmt uid);
     log ~title "Looking for %a in the uid_to_loc table" Logger.fmt (fun fmt ->
@@ -791,7 +791,7 @@ let doc_from_uid ~config ~loc uid =
   begin
     match uid with
     | (Shape.Uid.Item { comp_unit; _ } | Shape.Uid.Compilation_unit comp_unit)
-      when Env.get_unit_name () <> comp_unit ->
+      when Env.get_current_unit_name () <> comp_unit ->
       log ~title:"get_doc"
         "the doc (%a) you're looking for is in another\n\
         \      compilation unit (%s)" Logger.fmt
@@ -853,7 +853,7 @@ let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos =
       match path with
       | `Completion_entry (namespace, path, _loc) ->
         log ~title:"get_doc" "completion: looking for the doc of '%a'"
-          Logger.fmt (fun fmt -> Path.print fmt path);
+          Logger.fmt (fun fmt -> (Format_doc.compat Path.print) fmt path);
 
         let from_path = from_path ~config ~env ~local_defs ~namespace path in
         begin

src/analysis/occurrences.ml

@@ -31,7 +31,7 @@ let last_loc (loc : Location.t) lid =
   | Longident.Lident _ -> loc
   | _ ->
     let last_segment = Longident.last lid in
-    let needs_parens = Pprintast.needs_parens last_segment in
+    let needs_parens = Pprintast.needs_parens ~kind:Other last_segment in
     if not needs_parens then
       let last_size = last_segment |> String.length in
       { loc with
@@ -269,7 +269,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
     let def_uid_is_in_current_unit =
       let uid_comp_unit = comp_unit_of_uid def_uid in
       Option.value_map ~default:false uid_comp_unit
-        ~f:(String.equal @@ Env.get_unit_name ())
+        ~f:(String.equal @@ Env.get_current_unit_name ())
     in
     let status =
       match (scope, String.Set.to_list out_of_sync_files) with

src/analysis/parsetree_utils.ml

@@ -0,0 +1,5 @@
+open Parsetree
+
+type nonrec constant_desc = constant_desc
+
+let constant_desc c = c.pconst_desc

src/analysis/parsetree_utils.mli

@@ -0,0 +1,8 @@
+(** Utilities to provide a slightly more stable Parsetree API for alternative
+  clients like [ocaml-lsp]. *)
+
+open Parsetree
+
+type nonrec constant_desc = constant_desc
+
+val constant_desc : constant -> constant_desc

src/analysis/syntax_doc.ml

@@ -1,12 +1,19 @@
 open Browse_raw
 
+let { Logger.log } = Logger.for_section "syntax-doc"
+
 type syntax_info = Query_protocol.syntax_doc_result option
 
 let syntax_doc_url endpoint =
   let base_url = "https://v2.ocaml.org/releases/4.14/htmlman/" in
   base_url ^ endpoint
 
 let get_syntax_doc cursor_loc node : syntax_info =
+  log ~title:"get" "Looking for syntax doc of a node %a" Logger.fmt (fun fmt ->
+      Format.pp_print_list ~pp_sep:Format.pp_print_space
+        (fun fmt (_, node) ->
+          Format.fprintf fmt "%s" (Browse_raw.string_of_node node))
+        fmt node);
   match node with
   | (_, Type_kind _)
     :: (_, Type_declaration _)

src/analysis/tail_analysis.ml

@@ -76,8 +76,8 @@ let expr_tail_positions = function
   | Texp_extension_constructor _
   | Texp_letop _
   | Texp_hole -> []
-  | Texp_match (_, cs, _) -> List.map cs ~f:(fun c -> Case c)
-  | Texp_try (_, cs) -> List.map cs ~f:(fun c -> Case c)
+  | 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)
   | Texp_letexception (_, e)
   | Texp_let (_, _, e)

src/analysis/type_utils.ml

@@ -113,7 +113,8 @@ module Printtyp = struct
   let expand_sig env mty = Env.with_cmis @@ fun () -> Env.scrape_alias env mty
 
   let verbose_type_scheme env ppf t =
-    Printtyp.type_scheme ppf (expand_type env t)
+    let t = expand_type env t in
+    Printtyp.type_scheme ppf t
 
   let verbose_type_declaration env id ppf t =
     Printtyp.type_declaration id ppf (expand_type_decl env t)
@@ -265,7 +266,7 @@ let print_cstr_desc ppf cstr_desc =
 let print_constr ppf env lid =
   let cstr_desc = Env.find_constructor_by_name lid.Asttypes.txt env in
   (* FIXME: support Reader printer *)
-  print_cstr_desc ppf cstr_desc
+  (Format_doc.compat print_cstr_desc) ppf cstr_desc
 
 exception Fallback
 let type_in_env ?(verbosity = Verbosity.default) ?keywords ~context env ppf expr
@@ -344,7 +345,8 @@ let type_in_env ?(verbosity = Verbosity.default) ?keywords ~context env ppf expr
         false))
 
 let print_constr ~verbosity env ppf cd =
-  Printtyp.wrap_printing_env env ~verbosity @@ fun () -> print_cstr_desc ppf cd
+  Printtyp.wrap_printing_env env ~verbosity @@ fun () ->
+  (Format_doc.compat print_cstr_desc) ppf cd
 
 (* From doc-ock
    https://github.com/lpw25/doc-ock/blob/master/src/docOckAttrs.ml *)

src/analysis/typedtree_utils.ml

@@ -70,3 +70,30 @@ let pat_alias_pat_id_and_loc = function
   | Typedtree.{ pat_desc = Tpat_alias (pat, id, loc, _); _ } ->
     Some (pat, id, loc)
   | _ -> None
+
+open Typedtree
+
+type texp_match =
+  { expr : expression;
+    computation_cases : computation case list;
+    value_cases : value case list;
+    partial : partial
+  }
+
+type texp_try =
+  { expr : expression;
+    value_cases : value case list;
+    effect_cases : value case list
+  }
+
+let texp_match_of_expr expr =
+  match expr.exp_desc with
+  | Texp_match (expr, computation_cases, value_cases, partial) ->
+    Some { expr; computation_cases; value_cases; partial }
+  | _ -> None
+
+let texp_try_of_expr expr =
+  match expr.exp_desc with
+  | Texp_try (expr, value_cases, effect_cases) ->
+    Some { expr; value_cases; effect_cases }
+  | _ -> None