Support for OCaml 4.10 (#1117)

* import upstream ocaml-4.10+beta1 code

* create ocaml 4.10 folders

* remove envaux from upstream

* remove envaux from upstream

* WIP Support OCaml 4.10

* WIP Fixing 4.10 definitions

* WIP Typemod

* RESET ME

* Add Type_immediacy module

* build and run... until failwith "TODO"

* don't be to eager TODO

* implement env caching

* add test-current target

* catch errors in structure item

* catch initialization errors

* locate: use find_by_name, not lookup

* type_utils: use find_by_name, not lookup

* Env.sign_of_cmi: make locs ghost

* typemod: port omitted patch (should be upstreamed!)

* typemod: comment out some fatal errors

* rebuild 4.10 parser with latest menhir

* update upstream/ocaml_410 to 4.10.0

* port changes from 4.10.0

* FIX ME: disable short-paths for now

* REMOVE ME: release for OCaml 4.10 only

* update dune-release.sh script (allow explicit specification of package-version)

* Update CHANGES.md

* list 4.10 to magic_numbers

* same menhir as on other backends

* tests: -short-paths disabled on 4.10

* 408: env plumbing

* functor parameters and optional module names

* Env.fold_type_decls

* Result on 4.02

* WIP: first 409

* WIP: first 407

* WIP: first 406

* WIP: first 405

* WIP: first 404

* WIP: first 403

* WIP: first 402

* WIP: 407_0

* WIP: third (all backends)

* 4.10 in dune-workspace files

* Revert "FIX ME: disable short-paths for now"

This reverts commit 35cb490.

* rebased -short-paths

* tests: reenable short-paths for 4.10

* typeclass: pardon?

* 410: short-paths fixes and cleanup

* 410: finish fixing env

* update tests

* fix cons test

* fix errors in constrained env test

* Update opam constraints

* non_shadowed_pervasives: lookup was removed in our 4.09, remove from our 4.10

* typemod: recover from inclusion error on 4.10

* fix tests pre 4.10

* disable broken test on 4.10

* add 4.10 version of the test

Co-authored-by: Frédéric Bour <[email protected]>

Author: trefis

CHANGES.md

@@ -1,3 +1,10 @@
+merlin 3.3.4~4.10preview1
+=========================
+Mon Mar  2 14:26:32 CET 2020
+
+This is a preview release that adds support for OCaml 4.10.
+Short-path is disabled.  Other versions of OCaml are not supported.
+
 merlin 3.3.3
 ============
 Fri Nov 29 17:35:58 CET 2019

Makefile

@@ -16,6 +16,10 @@ test:
 	dune build --always-show-command-line --workspace=dune-workspace.test
 	dune runtest --workspace=dune-workspace.test
 
+test-current:
+	dune build --always-show-command-line
+	dune runtest
+
 preprocess:
 	dune build --always-show-command-line @preprocess
 

dune-release.sh

@@ -1,13 +1,20 @@
 #!/bin/sh
 
 TAG="$1"
+VER="$2"
 
 if [ -z "$TAG" ]; then
-  printf "Usage: ./dune-release.sh <tag-name>\n"
+  printf "Usage: ./dune-release.sh <tag-name> [<pkg-version>]\n"
   printf "Please make sure that dune-release is available.\n"
   exit 1
 fi
 
+FLAGS="-t $TAG"
+
+if [ -n "$VER" ]; then
+  FLAGS="$FLAGS --pkg-version=$VER"
+fi
+
 step()
 {
   printf "Continue? [Yn] "
@@ -16,10 +23,10 @@ step()
   if [ "x$action" == "xN" ]; then exit 2; fi
 }
 
-dune-release distrib -p merlin -n merlin -t "$TAG" --skip-tests #--skip-lint
+dune-release distrib -p merlin -n merlin $FLAGS --skip-tests #--skip-lint
 step
-dune-release publish distrib -p merlin -n merlin -t "$TAG"
+dune-release publish distrib -p merlin -n merlin $FLAGS
 step
-dune-release opam pkg -p merlin -n merlin -t "$TAG"
+dune-release opam pkg -p merlin -n merlin $FLAGS
 step
-dune-release opam submit -p merlin -n merlin -t "$TAG"
+dune-release opam submit -p merlin -n merlin $FLAGS

dune-workspace.template

@@ -5,5 +5,6 @@
 (context (opam (switch 4.05.0)))
 (context (opam (switch 4.06.1)))
 (context (opam (switch 4.07.1)))
-(context (opam (switch 4.08.1) (merlin)))
+(context (opam (switch 4.08.1)))
 (context (opam (switch 4.09.0)))
+(context (opam (switch 4.10.0) (merlin)))

dune-workspace.test

@@ -6,3 +6,4 @@
 (context (opam (switch 4.07.1)))
 (context (opam (switch 4.08.1)))
 (context (opam (switch 4.09.0)))
+(context (opam (switch 4.10.0) (merlin)))

merlin.opam

@@ -10,7 +10,7 @@ build: [
   ["dune" "runtest" "-p" name "-j" jobs] {with-test}
 ]
 depends: [
-  "ocaml" {>= "4.02.1" & < "4.10"}
+  "ocaml" {>= "4.02.3"}
   "dune" {>= "1.8.0"}
   "ocamlfind" {>= "1.5.2"}
   "yojson" {>= "1.6.0"}

src/analysis/completion.ml

@@ -240,9 +240,6 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty =
 let item_for_global_module name =
   {name; kind = `Module; desc = `None; info = `None; deprecated = false}
 
-let fold_types f id env acc =
-  Env.fold_types (fun s p (decl,_) acc -> f s p decl acc) id env acc
-
 let fold_constructors f id env acc =
   Env.fold_constructors
     (fun constr acc -> f constr.Types.cstr_name constr acc)
@@ -397,7 +394,7 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env
         ) prefix_path env []
 
       | `Types ->
-        fold_types (fun name path decl candidates ->
+        Env.fold_type_decls (fun name path decl candidates ->
           if not @@ validate `Lident `Typ name then candidates else
           make_weighted_candidate ~exact:(name = prefix) name ~path (`Typ decl)
             ~loc:decl.Types.type_loc ~attrs:(type_attributes decl)

src/analysis/destruct.ml

@@ -404,9 +404,8 @@ let node config source node parents =
     let pexp = filter_expr_attr (Untypeast.untype_expression expr) in
     let needs_parentheses, result =
       if is_package ty then (
-        let name = Location.mknoloc "M" in
         let mode = Ast_helper.Mod.unpack pexp in
-        false, Ast_helper.Exp.letmodule name mode placeholder
+        false, Ast_helper.Exp.letmodule_no_opt "M" mode placeholder
       ) else (
         let ps = gen_patterns expr.Typedtree.exp_env ty in
         let cases  =

src/analysis/locate.ml

@@ -628,27 +628,25 @@ end = struct
             raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))
           | `Constr ->
             log ~title:"lookup" "lookup in constructor namespace" ;
-            let cd = Env.lookup_constructor ident env in
+            let cd = Env.find_constructor_by_name ident env in
             let path, loc = path_and_loc_of_cstr cd env in
             (* TODO: Use [`Constr] here instead of [`Type] *)
             raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))
           | `Mod ->
             log ~title:"lookup" "lookup in module namespace" ;
-            let path = Env.lookup_module ~load:true ident env in
-            let md = Env.find_module path env in
+            let path, md = Env.find_module_by_name ident env in
             raise (Found (path, Namespaced_path.of_path ~namespace:`Mod path, md.Types.md_loc))
           | `Modtype ->
             log ~title:"lookup" "lookup in module type namespace" ;
-            let path, mtd = Env.lookup_modtype ident env in
+            let path, mtd = Env.find_modtype_by_name ident env in
             raise (Found (path, Namespaced_path.of_path ~namespace:`Modtype path, mtd.Types.mtd_loc))
           | `Type ->
             log ~title:"lookup" "lookup in type namespace" ;
-            let path = Env.lookup_type ident env in
-            let typ_decl = Env.find_type path env in
+            let path, typ_decl = Env.find_type_by_name ident env in
             raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, typ_decl.Types.type_loc))
           | `Vals ->
             log ~title:"lookup" "lookup in value namespace" ;
-            let path, val_desc = Env.lookup_value ident env in
+            let path, val_desc = Env.find_value_by_name ident env in
             raise (Found (path, Namespaced_path.of_path ~namespace:`Vals path, val_desc.Types.val_loc))
           | `This_label lbl ->
             log ~title:"lookup"
@@ -658,7 +656,7 @@ end = struct
             raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))
           | `Labels ->
             log ~title:"lookup" "lookup in label namespace" ;
-            let lbl = Env.lookup_label ident env in
+            let lbl = Env.find_label_by_name ident env in
             let path, loc = path_and_loc_from_label lbl env in
             (* TODO: Use [`Labels] here instead of [`Type] *)
             raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))

src/analysis/outline.ml

@@ -69,10 +69,17 @@ let rec summarize node =
 
   | Module_declaration md ->
     let children = get_mod_children node in
-    Some (mk ~children ~location `Module None md.md_id)
-  | Module_binding mb     ->
+    begin match Raw_compat.md_id md with
+      | None -> None
+      | Some id -> Some (mk ~children ~location `Module None id)
+    end
+
+  | Module_binding mb ->
     let children = get_mod_children node in
-    Some (mk ~children ~location `Module None mb.mb_id)
+    begin match Raw_compat.mb_id mb with
+      | None -> None
+      | Some id -> Some (mk ~children ~location `Module None id)
+    end
 
   | Module_type_declaration mtd ->
     let children = get_mod_children node in

src/analysis/polarity_search.ml

@@ -80,7 +80,8 @@ let match_query env query t =
 let build_query ~positive ~negative env =
   let prepare r l =
     if l = Longident.Lident "fun" then (incr r; None) else
-    Some (normalize_path env (Env.lookup_type l env))
+    let set, _ = Env.find_type_by_name l env in
+    Some (normalize_path env set)
   in
   let pos_fun = ref 0 and neg_fun = ref 0 in
   let positive = List.filter_map positive ~f:(prepare pos_fun) in
@@ -104,7 +105,7 @@ let directories ~global_modules env =
   in
   List.fold_left ~f:(fun l name ->
       let lident = Longident.Lident name in
-      match Env.lookup_module ~load:true lident env with
+      match Env.find_module_by_name lident env with
       | exception _ -> l
       | _ -> Trie (name, lident, lazy (explore lident env)) :: l
     ) ~init:[] global_modules
@@ -124,7 +125,7 @@ let execute_query query env dirs =
   in
   let rec recurse acc (Trie (_, dir, children)) =
     match
-      ignore (Env.lookup_module ~load:true dir env);
+      ignore (Env.find_module_by_name dir env);
       Lazy.force children
     with
     | children ->

src/analysis/type_utils.ml

@@ -40,12 +40,11 @@ let parse_expr ?(keywords=Lexer_raw.keywords []) expr =
   Parser_raw.parse_expression lexer lexbuf
 
 let lookup_module name env =
-  let path = Env.lookup_module ~load:true name env in
-  let md = Env.find_module path env in
+  let path, md = Env.find_module_by_name name env in
   path, md.Types.md_type, md.Types.md_attributes
 
 let lookup_modtype name env =
-  let path, mdtype = Env.lookup_modtype name env in
+  let path, mdtype = Env.find_modtype_by_name name env in
   path, mdtype.Types.mtd_type
 
 let lookup_module_or_modtype name env =
@@ -155,15 +154,14 @@ let rec mod_smallerthan n m =
         | Some n', _ -> Some (succ n')
       end
     end
-  | Mty_functor (_,m1,m2) ->
+  | Mty_functor _ ->
+    let (m1,m2) = unpack_functor m in
     begin
-      match m1 with
-      | None -> None
-      | Some m1 ->
-      match mod_smallerthan n m1 with
-      | None -> None
-      | Some n1 ->
-      match mod_smallerthan (n - n1) m2 with
+      match mod_smallerthan n m2, m1 with
+      | None, _ -> None
+      | result, Unit -> result
+      | Some n1, Named (_, mt) ->
+      match mod_smallerthan (n - n1) mt with
       | None -> None
       | Some n2 -> Some (n1 + n2)
     end
@@ -243,8 +241,7 @@ let type_in_env ?(verbosity=0) ?keywords env ppf expr =
         true
       with exn ->
         try
-          let p = Env.lookup_type longident.Asttypes.txt env in
-          let t = Env.find_type p env in
+          let p, t = Env.find_type_by_name longident.Asttypes.txt env in
           Printtyp.type_declaration env
             (Ident.create_persistent (* Incorrect, but doesn't matter. *)
                (Path.last p))
@@ -275,7 +272,7 @@ let type_in_env ?(verbosity=0) ?keywords env ppf expr =
         with _ ->
           try
             let cstr_desc =
-              Env.lookup_constructor longident.Asttypes.txt env
+              Env.find_constructor_by_name longident.Asttypes.txt env
             in
                   (*
                      Format.pp_print_string ppf name;