diff --git a/.github/workflows/changelog.yml b/.github/workflows/changelog.yml index 6d9daf7bbb..5ba83ec6b7 100644 --- a/.github/workflows/changelog.yml +++ b/.github/workflows/changelog.yml @@ -2,7 +2,7 @@ name: Changelog check on: pull_request: - branches: [ master ] + branches: [ main ] types: [ opened, synchronize, reopened, labeled, unlabeled ] jobs: diff --git a/CHANGES.md b/CHANGES.md index 14cbf0d40a..ab2a6b5b64 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,15 @@ +merlin 4.18 +=========== +Tue Nov 26 17:30:42 CET 2024 + + + merlin binary + - Respect the `EXCLUDE_QUERY_DIR` configuration directive when looking for + cmt files (#1854) + - Fix exception in polarity search (#1858 fixes #1113) + - Fix type-enclosing results instability. This reverts some overly + aggressive deduplication that should be done on the client side. (#1864) + + merlin 4.17.1 ============= Fri Sep 27 12:02:42 CEST 2024 diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 41d4f6330e..3bc54e2f8e 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -12,7 +12,7 @@ build: [ ] depends: [ "ocaml" {>= "4.14"} - "dune" {>= "2.9.0"} + "dune" {>= "3.0.0"} "merlin-lib" {>= "4.17"} "ocamlfind" {>= "1.6.0"} ] diff --git a/merlin-lib.opam b/merlin-lib.opam index 72270d1c42..a3a98730a9 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -13,7 +13,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} - "alcotest" {with-test} + "alcotest" {with-test & >= "1.3.0" } "menhir" {dev & >= "20201216"} "menhirLib" {dev & >= "20201216"} "menhirSdk" {dev & >= "20201216"} diff --git a/merlin.opam b/merlin.opam index afa0566dbd..1b9f0a718e 100644 --- a/merlin.opam +++ b/merlin.opam @@ -14,7 +14,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "merlin-lib" {= version} - "dot-merlin-reader" {>= "4.17"} + "dot-merlin-reader" {>= "4.17.1"} "yojson" {>= "2.0.0"} "conf-jq" {with-test} "ppxlib" {with-test} diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index 7c372f6548..c86b6449fe 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -59,3 +59,55 @@ let parse_identifier (config, source) pos = "paths: [%s]" (String.concat ~sep:";" (List.map path ~f:(fun l -> l.Location.txt))); path + +let reconstruct_identifier pipeline pos = function + | None -> + let config = Mpipeline.input_config pipeline in + let source = Mpipeline.raw_source pipeline in + let path = parse_identifier (config, source) pos in + let reify dot = + if + dot = "" + || (dot.[0] >= 'a' && dot.[0] <= 'z') + || (dot.[0] >= 'A' && dot.[0] <= 'Z') + then dot + else "( " ^ dot ^ ")" + in + begin + match path with + | [] -> [] + | base :: tail -> + let f { Location.txt = base; loc = bl } { Location.txt = dot; loc = dl } + = + let loc = Location_aux.union bl dl in + let txt = base ^ "." ^ reify dot in + Location.mkloc txt loc + in + [ List.fold_left tail ~init:base ~f ] + end + | Some (expr, offset) -> + let loc_start = + let l, c = Lexing.split_pos pos in + Lexing.make_pos (l, c - offset) + in + let shift loc int = + let l, c = Lexing.split_pos loc in + Lexing.make_pos (l, c + int) + in + let add_loc source = + let loc = + { Location.loc_start; + loc_end = shift loc_start (String.length source); + loc_ghost = false + } + in + Location.mkloc source loc + in + let len = String.length expr in + let rec aux acc i = + if i >= len then List.rev_map ~f:add_loc (expr :: acc) + else if expr.[i] = '.' then + aux (String.sub expr ~pos:0 ~len:i :: acc) (succ i) + else aux acc (succ i) + in + aux [] offset diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 7fdab690e3..0d508244ff 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -29,3 +29,11 @@ val parenthesize_name : string -> string the location of each of its components. *) val parse_identifier : Mconfig.t * Msource.t -> Lexing.position -> string Location.loc list + +(** [reconstruct_identifier pipeline pos] returns growing ranges around [pos] and the + associated identifier. *) +val reconstruct_identifier : + Mpipeline.t -> + Lexing.position -> + (string * int) option -> + string Location.loc list diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 159f224b8a..79b6b6b837 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -68,8 +68,10 @@ let build_query ~positive ~negative env = incr r; None) else - let set, _ = Env.find_type_by_name l env in - Some (normalize_path env set) + try + let set, _ = Env.find_type_by_name l env in + Some (normalize_path env set) + with Not_found -> None in let pos_fun = ref 0 and neg_fun = ref 0 in let positive = List.filter_map positive ~f:(prepare pos_fun) in diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml index 096ad2d571..2b1435e9c0 100644 --- a/src/analysis/type_enclosing.ml +++ b/src/analysis/type_enclosing.ml @@ -1,4 +1,5 @@ open Std +open Type_utils let log_section = "type-enclosing" let { Logger.log } = Logger.for_section log_section @@ -7,11 +8,34 @@ type type_info = | Modtype of Env.t * Types.module_type | Type of Env.t * Types.type_expr | Type_decl of Env.t * Ident.t * Types.type_declaration + | Type_constr of Env.t * Types.constructor_description | String of string type typed_enclosings = (Location.t * type_info * Query_protocol.is_tail_position) list +let print_type ~verbosity type_info = + let ppf = Format.str_formatter in + let wrap_printing_env = Printtyp.wrap_printing_env ~verbosity in + match type_info with + | Type (env, t) -> + wrap_printing_env env (fun () -> + print_type_with_decl ~verbosity env ppf t; + Format.flush_str_formatter ()) + | Type_decl (env, id, t) -> + wrap_printing_env env (fun () -> + Printtyp.type_declaration env id ppf t; + Format.flush_str_formatter ()) + | Type_constr (env, cd) -> + wrap_printing_env env (fun () -> + print_constr ~verbosity env ppf cd; + Format.flush_str_formatter ()) + | Modtype (env, m) -> + wrap_printing_env env (fun () -> + Printtyp.modtype env ppf m; + Format.flush_str_formatter ()) + | String s -> s + let from_nodes ~path = let aux (env, node, tail) = let open Browse_raw in @@ -89,14 +113,10 @@ let from_reconstructed ~nodes ~cursor ~verbosity exprs = (* Retrieve the type from the AST when it is possible *) | Some (Context.Constructor (cd, loc)) -> log ~title:"from_reconstructed" "ctx: constructor %s" cd.cstr_name; - let ppf, to_string = Format.to_string () in - Type_utils.print_constr ~verbosity env ppf cd; - Some (loc, String (to_string ()), `No) + Some (loc, Type_constr (env, cd), `No) | Some (Context.Label { lbl_name; lbl_arg; _ }) -> log ~title:"from_reconstructed" "ctx: label %s" lbl_name; - let ppf, to_string = Format.to_string () in - Type_utils.print_type_with_decl ~verbosity env ppf lbl_arg; - Some (loc, String (to_string ()), `No) + Some (loc, Type (env, lbl_arg), `No) | Some Context.Constant -> None | _ -> ( let context = Option.value ~default:Context.Expr context in diff --git a/src/analysis/type_enclosing.mli b/src/analysis/type_enclosing.mli index 50a408b46a..87538b63e0 100644 --- a/src/analysis/type_enclosing.mli +++ b/src/analysis/type_enclosing.mli @@ -38,11 +38,14 @@ type type_info = | Modtype of Env.t * Types.module_type | Type of Env.t * Types.type_expr | Type_decl of Env.t * Ident.t * Types.type_declaration + | Type_constr of Env.t * Types.constructor_description | String of string type typed_enclosings = (Location.t * type_info * Query_protocol.is_tail_position) list +val print_type : verbosity:Mconfig.Verbosity.t -> type_info -> string + val from_nodes : path:(Env.t * Browse_raw.node * Query_protocol.is_tail_position) list -> typed_enclosings diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 836c3334f6..67a11911e1 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -569,7 +569,11 @@ let all_commands = ~spec: [ arg "-position" " Position to complete" (marg_position (fun pos (query, _pos) -> (query, pos))); - arg "-query" " Query of the form TODO" + arg "-query" + " Query of the form every input parameters prefixed by `-` \ + and output parameters prefixed by `+`. In example: -string \ + +option will fetch function that takes string and returns an \ + option. (You can't parametrize types in polarity queries)" (Marg.param "string" (fun query (_prefix, pos) -> (query, pos))) ] ~default:("", `None) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index b7ea91f4fd..c52bb81a65 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -199,65 +199,6 @@ let dump pipeline = function source, parsetree, ppxed-source, ppxed-parsetree, typedtree, \ env/fullenv (at {col:, line:})" -let reconstruct_identifier pipeline pos = function - | None -> - let path = - Mreader.reconstruct_identifier - (Mpipeline.input_config pipeline) - (Mpipeline.raw_source pipeline) - pos - in - let path = Mreader_lexer.identifier_suffix path in - Logger.log ~section:Type_enclosing.log_section - ~title:"reconstruct-identifier" "paths: [%s]" - (String.concat ~sep:";" (List.map path ~f:(fun l -> l.Location.txt))); - let reify dot = - if - dot = "" - || (dot.[0] >= 'a' && dot.[0] <= 'z') - || (dot.[0] >= 'A' && dot.[0] <= 'Z') - then dot - else "( " ^ dot ^ ")" - in - begin - match path with - | [] -> [] - | base :: tail -> - let f { Location.txt = base; loc = bl } { Location.txt = dot; loc = dl } - = - let loc = Location_aux.union bl dl in - let txt = base ^ "." ^ reify dot in - Location.mkloc txt loc - in - [ List.fold_left tail ~init:base ~f ] - end - | Some (expr, offset) -> - let loc_start = - let l, c = Lexing.split_pos pos in - Lexing.make_pos (l, c - offset) - in - let shift loc int = - let l, c = Lexing.split_pos loc in - Lexing.make_pos (l, c + int) - in - let add_loc source = - let loc = - { Location.loc_start; - loc_end = shift loc_start (String.length source); - loc_ghost = false - } - in - Location.mkloc source loc - in - let len = String.length expr in - let rec aux acc i = - if i >= len then List.rev_map ~f:add_loc (expr :: acc) - else if expr.[i] = '.' then - aux (String.sub expr ~pos:0 ~len:i :: acc) (succ i) - else aux acc (succ i) - in - aux [] offset - let dispatch pipeline (type a) : a Query_protocol.t -> a = function | Type_expr (source, pos) -> let typer = Mpipeline.typer_result pipeline in @@ -282,10 +223,29 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function | browse -> Browse_misc.annotate_tail_calls browse in - let result = Type_enclosing.from_nodes ~path in + (* Type enclosing results come from two sources: 1. the typedtree nodes + aroung the cursor's position and 2. the result of reconstructing the + identifier around the cursor and typing the resulting paths. + + Having the results from 2 is useful because ot is finer-grained than the + typedtree's nodes and can provide types for modules appearing in paths. + + This introduces two possible sources of duplicate results: + - Sometimes the typedtree nodes in 1 overlaps and we simply remove these. + - The last reconstructed enclosing usually overlaps with the first + typedtree node but the printed types are not always the same (generic / + specialized types). Because systematically printing these types to + compare them can be very expensive in the presence of large modules, we + defer this deduplication to the clients. + *) + let enclosing_nodes = + let cmp (loc1, _, _) (loc2, _, _) = Location_aux.compare loc1 loc2 in + (* There might be duplicates in the list: we remove them *) + Type_enclosing.from_nodes ~path |> List.dedup_adjacent ~cmp + in - (* enclosings of cursor in given expression *) - let exprs = reconstruct_identifier pipeline pos expro in + (* Enclosings of cursor in given expression *) + let exprs = Misc_utils.reconstruct_identifier pipeline pos expro in let () = Logger.log ~section:Type_enclosing.log_section ~title:"reconstruct identifier" "%a" Logger.json (fun () -> @@ -309,42 +269,30 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun fmt (loc, _, _) -> Location.print_loc fmt loc)) small_enclosings); - - let ppf = Format.str_formatter in - let all_results = - List.mapi (small_enclosings @ result) ~f:(fun i (loc, text, tail) -> - let print = - match index with - | None -> true - | Some index -> index = i - in - let ret x = (loc, x, tail) in - match text with - | Type_enclosing.String str -> ret (`String str) - | Type_enclosing.Type (env, t) when print -> - Printtyp.wrap_printing_env env ~verbosity (fun () -> - Type_utils.print_type_with_decl ~verbosity env ppf t); - ret (`String (Format.flush_str_formatter ())) - | Type_enclosing.Type_decl (env, id, t) when print -> - Printtyp.wrap_printing_env env ~verbosity (fun () -> - Printtyp.type_declaration env id ppf t); - ret (`String (Format.flush_str_formatter ())) - | Type_enclosing.Modtype (env, m) when print -> - Printtyp.wrap_printing_env env ~verbosity (fun () -> - Printtyp.modtype env ppf m); - ret (`String (Format.flush_str_formatter ())) - | _ -> ret (`Index i)) - in - let normalize ({ Location.loc_start; loc_end; _ }, text, _tail) = - (Lexing.split_pos loc_start, Lexing.split_pos loc_end, text) - in - (* We remove duplicates from the list. Duplicates can appear when the type - from the reconstructed identifier is the same as the one stored in the - typedtree *) - List.merge_cons - ~f:(fun a b -> - if compare (normalize a) (normalize b) = 0 then Some b else None) - all_results + let all_results = List.concat [ small_enclosings; enclosing_nodes ] in + let index = + (* Clamp the index to [0; number_of_results[ *) + let number_of_results = List.length all_results in + match index with + | Some index when index < 0 -> Some 0 + | Some index when index >= number_of_results -> + Some (number_of_results - 1) + | index -> index + in + List.mapi all_results ~f:(fun i (loc, text, tail) -> + let print = + match index with + | None -> true + | Some index -> index = i + in + let ret x = (loc, x, tail) in + match text with + | Type_enclosing.String str -> ret (`String str) + | type_info -> + if print then + let printed_type = Type_enclosing.print_type ~verbosity type_info in + ret (`String printed_type) + else ret (`Index i)) | Enclosing pos -> let typer = Mpipeline.typer_result pipeline in let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in @@ -510,7 +458,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function match patho with | Some p -> p | None -> - let path = reconstruct_identifier pipeline pos None in + let path = Misc_utils.reconstruct_identifier pipeline pos None in let path = Mreader_lexer.identifier_suffix path in let path = List.map ~f:(fun { Location.txt; _ } -> txt) path in String.concat ~sep:"." path @@ -546,7 +494,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function match patho with | Some p -> p | None -> - let path = reconstruct_identifier pipeline pos None in + let path = Misc_utils.reconstruct_identifier pipeline pos None in let path = Mreader_lexer.identifier_suffix path in let path = List.map ~f:(fun { Location.txt; _ } -> txt) path in let path = String.concat ~sep:"." path in diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 222c119411..3e70898236 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -744,14 +744,14 @@ let source_path config = List.concat [ [ config.query.directory ]; stdlib; config.merlin.source_path ] |> List.filter_dup -let build_path config = +let collect_paths ~log_title ~config paths = let dirs = match config.ocaml.threads with | `None -> config.ocaml.include_dirs | `Threads -> "+threads" :: config.ocaml.include_dirs | `Vmthreads -> "+vmthreads" :: config.ocaml.include_dirs in - let dirs = config.merlin.cmi_path @ config.merlin.build_path @ dirs in + let dirs = paths @ dirs in let stdlib = stdlib config in let exp_dirs = List.map ~f:(Misc.expand_directory stdlib) dirs in let stdlib = if config.ocaml.no_std_include then [] else [ stdlib ] in @@ -760,23 +760,18 @@ let build_path config = if config.merlin.exclude_query_dir then dirs else config.query.directory :: dirs in - let result' = List.filter_dup result in - log ~title:"build_path" "%d items in path, %d after deduplication" - (List.length result) (List.length result'); - result' + let result = List.filter_dup result in + log ~title:log_title "%d items in path, %d after deduplication" + (List.length result) (List.length result); + result + +let build_path config = + collect_paths ~log_title:"build_path" ~config + (config.merlin.cmi_path @ config.merlin.build_path) let cmt_path config = - let dirs = - match config.ocaml.threads with - | `None -> config.ocaml.include_dirs - | `Threads -> "+threads" :: config.ocaml.include_dirs - | `Vmthreads -> "+vmthreads" :: config.ocaml.include_dirs - in - let dirs = config.merlin.cmt_path @ config.merlin.build_path @ dirs in - let stdlib = stdlib config in - let exp_dirs = List.map ~f:(Misc.expand_directory stdlib) dirs in - let stdlib = if config.ocaml.no_std_include then [] else [ stdlib ] in - config.query.directory :: List.rev_append exp_dirs stdlib + collect_paths ~log_title:"cmt_path" ~config + (config.merlin.cmt_path @ config.merlin.build_path) let global_modules ?(include_current = false) config = let modules = Misc.modules_in_path ~ext:".cmi" (build_path config) in diff --git a/tests/test-dirs/config/dune b/tests/test-dirs/config/dune index 3afbf37cb4..487c3246d9 100755 --- a/tests/test-dirs/config/dune +++ b/tests/test-dirs/config/dune @@ -1,5 +1,5 @@ (cram - (applies_to path-expansion) + (applies_to path-expansion exclude-query-dir) (enabled_if (<> %{os_type} Win32))) diff --git a/tests/test-dirs/config/exclude-query-dir.t b/tests/test-dirs/config/exclude-query-dir.t new file mode 100644 index 0000000000..162fcf5bcc --- /dev/null +++ b/tests/test-dirs/config/exclude-query-dir.t @@ -0,0 +1,40 @@ +Test the EXCLUDE_QUERY_DIR directive, which tells Merlin not to look for build artifacts +in the directory of the file being queried on. To test, we create a/test.ml, which depends +on b/foo.ml. The folder b contains a .cmt for the Foo module, and Merlin is configured to +look there. We also include a malformatted foo.cmt in the query directory. + $ mkdir a + $ mkdir b + + $ cat > a/test.ml << EOF + > let x = Foo.bar + > EOF + + $ cat > b/foo.ml << EOF + > let bar = 10 + > EOF + +Create the proper and malformatted .cmt files + $ $OCAMLC -c -bin-annot b/foo.ml + $ touch a/foo.cmt + +Configure Merlin + $ cat > a/.merlin << EOF + > S . + > B ../b + > S ../b + > EXCLUDE_QUERY_DIR + > EOF + +Perform the query + $ $MERLIN single locate -position 1:13 -filename a/test.ml < a/test.ml + { + "class": "return", + "value": { + "file": "$TESTCASE_ROOT/b/foo.ml", + "pos": { + "line": 1, + "col": 4 + } + }, + "notifications": [] + } diff --git a/tests/test-dirs/issue1109.t/run.t b/tests/test-dirs/issue1109.t/run.t index 37e5a134a9..fa6598f9d6 100644 --- a/tests/test-dirs/issue1109.t/run.t +++ b/tests/test-dirs/issue1109.t/run.t @@ -20,9 +20,9 @@ }, "end": { "line": 5, - "col": 16 + "col": 14 }, - "type": "'a", + "type": "'a -> 'a", "tail": "no" } ] diff --git a/tests/test-dirs/misc/load_path.t b/tests/test-dirs/misc/load_path.t index 19bffb07f6..3e5dbc2fb9 100644 --- a/tests/test-dirs/misc/load_path.t +++ b/tests/test-dirs/misc/load_path.t @@ -16,6 +16,18 @@ Here is what merlin sees: { "class": "return", "value": [ + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "int", + "tail": "no" + }, { "start": { "line": 1, diff --git a/tests/test-dirs/search/issue1113.t b/tests/test-dirs/search/issue1113.t new file mode 100644 index 0000000000..0730986c43 --- /dev/null +++ b/tests/test-dirs/search/issue1113.t @@ -0,0 +1,101 @@ + $ cat >main.ml < let f x = succ x + > EOF + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-ezfnifzen +ezfzef" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "CamlinternalOO.dummy_table", + "desc": "CamlinternalOO.table" + } + { + "name": "CamlinternalOO.params", + "desc": "CamlinternalOO.params" + } + { + "name": "Dynlink.is_native", + "desc": "bool" + } + { + "name": "__FILE__", + "desc": "string" + } + { + "name": "__FILE__", + "desc": "string" + } + { + "name": "__FUNCTION__", + "desc": "string" + } + { + "name": "__FUNCTION__", + "desc": "string" + } + { + "name": "__LINE__", + "desc": "int" + } + { + "name": "__LINE__", + "desc": "int" + } + { + "name": "__LOC__", + "desc": "string" + } + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "ezfnifzen -> ezfzef" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost}' + { + "name": "Gc.major", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "Gc.minor", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "Sys.time", + "type": "unit -> float", + "cost": 13 + } + { + "name": "read_int", + "type": "unit -> int", + "cost": 13 + } + { + "name": "read_int", + "type": "unit -> int", + "cost": 13 + } + { + "name": "Unix.fork", + "type": "unit -> int", + "cost": 13 + } + { + "name": "Unix.time", + "type": "unit -> float", + "cost": 13 + } + { + "name": "flush_all", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "flush_all", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "read_line", + "type": "unit -> string", + "cost": 13 + } diff --git a/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t b/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t index 23f040870b..54e6705bf4 100644 --- a/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t +++ b/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t @@ -4,6 +4,18 @@ Various parts of the cons.ml: $ $MERLIN single type-enclosing -position 4:14 -verbosity 0 \ > -filename ./cons.ml < ./cons.ml| jq ".value[0:2]" [ + { + "start": { + "line": 4, + "col": 13 + }, + "end": { + "line": 4, + "col": 14 + }, + "type": "t", + "tail": "no" + }, { "start": { "line": 4, @@ -37,14 +49,14 @@ Various parts of the cons.ml: }, { "start": { - "line": 7, - "col": 2 + "line": 8, + "col": 4 }, "end": { "line": 8, - "col": 11 + "col": 5 }, - "type": "unit", + "type": "t", "tail": "no" } ] @@ -127,13 +139,13 @@ Various parts of the cons.ml: { "start": { "line": 15, - "col": 6 + "col": 12 }, "end": { "line": 15, - "col": 22 + "col": 15 }, - "type": "unit -> M.t", + "type": "M.t", "tail": "no" } ] @@ -233,6 +245,18 @@ the expression reconstructed from (M|.A 3). $ $MERLIN single type-enclosing -position 26:11 -verbosity 0 \ > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]" [ + { + "start": { + "line": 26, + "col": 8 + }, + "end": { + "line": 26, + "col": 11 + }, + "type": "int", + "tail": "no" + }, { "start": { "line": 26, diff --git a/tests/test-dirs/type-enclosing/generic-types.t b/tests/test-dirs/type-enclosing/generic-types.t new file mode 100644 index 0000000000..b3ed43681a --- /dev/null +++ b/tests/test-dirs/type-enclosing/generic-types.t @@ -0,0 +1,297 @@ + $ cat >main.ml <<'EOF' + > let _ = List.map Fun.id [3] + > EOF + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 1:14 -index 0 \ + > -filename ./main.ml < ./main.ml | jq '.value[0,1]' + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "('a -> 'b) -> 'a list -> 'b list", + "tail": "no" + } + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": 1, + "tail": "no" + } + +With index 1 only the second is shown (the first is a string so it is always shown): + $ $MERLIN single type-enclosing -position 1:14 -index 1 \ + > -filename ./main.ml < ./main.ml | jq '.value[0,1]' + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "('a -> 'b) -> 'a list -> 'b list", + "tail": "no" + } + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + } + + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 1:10 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 12 + }, + "type": "(module Stdlib__List)", + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + +With index 1 only the second is shown (the first is a string so it is always shown): +FIXME? We don't see the generic version + $ $MERLIN single type-enclosing -short-paths -position 1:10 -index 1 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 12 + }, + "type": "(module List)", + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + + $ cat >main.ml <<'EOF' + > module List = struct let map : (int -> int) -> int list -> int list = List.map end + > let _ = List.map Fun.id [3] + > EOF + +With index 0 only the first type is shown. The next enclosing is not +deduplicated as intended, this should be done by the client. + $ $MERLIN single type-enclosing -position 2:14 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + +And with index=1 the correct type is shown + $ $MERLIN single type-enclosing -position 2:14 -index 1 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + +And with index>=3 Merlin sticks to the last item + $ $MERLIN single type-enclosing -position 2:14 -index 7 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 27 + }, + "type": "int list", + "tail": "no" + } + ], + "notifications": [] + } diff --git a/tests/test-dirs/type-enclosing/github1003.t/run.t b/tests/test-dirs/type-enclosing/github1003.t/run.t index dd4730cc33..6b79d9f057 100644 --- a/tests/test-dirs/type-enclosing/github1003.t/run.t +++ b/tests/test-dirs/type-enclosing/github1003.t/run.t @@ -1,6 +1,18 @@ $ $MERLIN single type-enclosing -position 5:14 -verbosity 0 \ > -filename ./issue1003.ml < ./issue1003.ml | jq ".value[0:2]" [ + { + "start": { + "line": 5, + "col": 8 + }, + "end": { + "line": 5, + "col": 16 + }, + "type": "int", + "tail": "no" + }, { "start": { "line": 5, diff --git a/tests/test-dirs/type-enclosing/issue1477.t b/tests/test-dirs/type-enclosing/issue1477.t index 1b1e06ff72..78e3633aca 100644 --- a/tests/test-dirs/type-enclosing/issue1477.t +++ b/tests/test-dirs/type-enclosing/issue1477.t @@ -19,6 +19,18 @@ "type": "int -> int", "tail": "no" }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 9 + }, + "type": "int -> int", + "tail": "no" + }, { "start": { "line": 2, diff --git a/tests/test-dirs/type-enclosing/letop.t/run.t b/tests/test-dirs/type-enclosing/letop.t/run.t index 29b94b5433..62fa2c86a3 100644 --- a/tests/test-dirs/type-enclosing/letop.t/run.t +++ b/tests/test-dirs/type-enclosing/letop.t/run.t @@ -86,9 +86,9 @@ Various parts of the letop: }, "end": { "line": 4, - "col": 37 + "col": 29 }, - "type": "'a option", + "type": "('a, 'b) Hashtbl.t -> 'a -> 'b option", "tail": "no" } ] @@ -111,13 +111,13 @@ Various parts of the letop: { "start": { "line": 4, - "col": 13 + "col": 30 }, "end": { "line": 4, - "col": 37 + "col": 33 }, - "type": "'a option", + "type": "('a, 'b) Hashtbl.t", "tail": "no" } ] @@ -140,13 +140,13 @@ Various parts of the letop: { "start": { "line": 4, - "col": 13 + "col": 34 }, "end": { "line": 4, "col": 37 }, - "type": "'a option", + "type": "'a", "tail": "no" } ] @@ -175,7 +175,7 @@ Various parts of the letop: }, "end": { "line": 5, - "col": 9 + "col": 5 }, "type": "int", "tail": "no" diff --git a/tests/test-dirs/type-enclosing/mod-type.t/run.t b/tests/test-dirs/type-enclosing/mod-type.t/run.t index 2506d0adc5..41013d081f 100644 --- a/tests/test-dirs/type-enclosing/mod-type.t/run.t +++ b/tests/test-dirs/type-enclosing/mod-type.t/run.t @@ -32,6 +32,18 @@ Get the type of a module type with the same name as a module: $ $MERLIN single type-enclosing -position 5:9 -verbosity 2 \ > -filename ./module_type.mli < ./module_type.mli | jq ".value[0:2]" [ + { + "start": { + "line": 5, + "col": 8 + }, + "end": { + "line": 5, + "col": 9 + }, + "type": "sig type a end", + "tail": "no" + }, { "start": { "line": 5, @@ -64,7 +76,7 @@ Get the type of a module type with the same name as a module: { "start": { "line": 7, - "col": 8 + "col": 23 }, "end": { "line": 7, @@ -93,7 +105,7 @@ Get the type of a module type with the same name as a module: { "start": { "line": 7, - "col": 8 + "col": 23 }, "end": { "line": 7, diff --git a/tests/test-dirs/type-enclosing/objects.t/run.t b/tests/test-dirs/type-enclosing/objects.t/run.t index a29e9d65ed..7fab615004 100644 --- a/tests/test-dirs/type-enclosing/objects.t/run.t +++ b/tests/test-dirs/type-enclosing/objects.t/run.t @@ -112,9 +112,9 @@ }, "end": { "line": 14, - "col": 14 + "col": 9 }, - "type": "int -> unit", + "type": "< pop : int option; push : int -> unit >", "tail": "no" } ] diff --git a/tests/test-dirs/type-enclosing/record.t/run.t b/tests/test-dirs/type-enclosing/record.t/run.t index aee28c9d48..49eb8f5c0b 100644 --- a/tests/test-dirs/type-enclosing/record.t/run.t +++ b/tests/test-dirs/type-enclosing/record.t/run.t @@ -95,9 +95,9 @@ }, "end": { "line": 8, - "col": 17 + "col": 9 }, - "type": "unit", + "type": "t", "tail": "no" } ] @@ -124,9 +124,9 @@ }, "end": { "line": 8, - "col": 17 + "col": 9 }, - "type": "type unit = ()", + "type": "type t = { mutable b : float; }", "tail": "no" } ] diff --git a/tests/test-dirs/type-enclosing/te-413-features.t b/tests/test-dirs/type-enclosing/te-413-features.t index da5ab50a03..d091b4df86 100644 --- a/tests/test-dirs/type-enclosing/te-413-features.t +++ b/tests/test-dirs/type-enclosing/te-413-features.t @@ -21,13 +21,13 @@ Named existentials in patterns { "start": { "line": 3, - "col": 51 + "col": 59 }, "end": { "line": 3, - "col": 65 + "col": 60 }, - "type": "unit", + "type": "a", "tail": "no" } ] diff --git a/tests/test-dirs/type-enclosing/te-modules.t b/tests/test-dirs/type-enclosing/te-modules.t new file mode 100644 index 0000000000..6d38e257a5 --- /dev/null +++ b/tests/test-dirs/type-enclosing/te-modules.t @@ -0,0 +1,232 @@ + $ cat >main.ml <<'EOF' + > module M = struct module N = struct let x = () let y = () end end + > module B = M.N + > EOF + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 2:7 -verbosity 0 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 7 + }, + "end": { + "line": 2, + "col": 8 + }, + "type": "(module M.N)", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + } + ], + "notifications": [] + } + + $ $MERLIN single type-enclosing -position 2:7 -verbosity 1 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 7 + }, + "end": { + "line": 2, + "col": 8 + }, + "type": "sig val x : unit val y : unit end", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + } + ], + "notifications": [] + } + + $ cat >main.ml <<'EOF' + > module M = struct module N = List end + > module B = M.N + > EOF + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 2:13 -verbosity 0 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": "(module List)", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + + $ $MERLIN single type-enclosing -position 2:13 -verbosity 1 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": "sig + type 'a t = 'a list = [] | (::) of 'a * 'a list + val length : 'a list -> int + val compare_lengths : 'a list -> 'b list -> int + val compare_length_with : 'a list -> int -> int + val cons : 'a -> 'a list -> 'a list + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val nth_opt : 'a list -> int -> 'a option + val rev : 'a list -> 'a list + val init : int -> (int -> 'a) -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool + val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int + val iter : ('a -> unit) -> 'a list -> unit + val iteri : (int -> 'a -> unit) -> 'a list -> unit + val map : ('a -> 'b) -> 'a list -> 'b list + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val filter_map : ('a -> 'b option) -> 'a list -> 'b list + val concat_map : ('a -> 'b list) -> 'a list -> 'b list + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + val for_all : ('a -> bool) -> 'a list -> bool + val exists : ('a -> bool) -> 'a list -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> 'a list -> bool + val memq : 'a -> 'a list -> bool + val find : ('a -> bool) -> 'a list -> 'a + val find_opt : ('a -> bool) -> 'a list -> 'a option + val find_map : ('a -> 'b option) -> 'a list -> 'b option + val filter : ('a -> bool) -> 'a list -> 'a list + val find_all : ('a -> bool) -> 'a list -> 'a list + val filteri : (int -> 'a -> bool) -> 'a list -> 'a list + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val partition_map : + ('a -> ('b, 'c) Either.t) -> 'a list -> 'b list * 'c list + val assoc : 'a -> ('a * 'b) list -> 'b + val assoc_opt : 'a -> ('a * 'b) list -> 'b option + val assq : 'a -> ('a * 'b) list -> 'b + val assq_opt : 'a -> ('a * 'b) list -> 'b option + val mem_assoc : 'a -> ('a * 'b) list -> bool + val mem_assq : 'a -> ('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + val to_seq : 'a list -> 'a Seq.t + val of_seq : 'a Seq.t -> 'a list + end", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } diff --git a/tests/test-dirs/type-enclosing/types.t/run.t b/tests/test-dirs/type-enclosing/types.t/run.t index d86ca72e2c..cf9d7175a1 100644 --- a/tests/test-dirs/type-enclosing/types.t/run.t +++ b/tests/test-dirs/type-enclosing/types.t/run.t @@ -30,6 +30,18 @@ $ $MERLIN single type-enclosing -position 5:11 -verbosity 1 \ > -filename ./types.ml < ./types.ml | jq ".value" [ + { + "start": { + "line": 5, + "col": 10 + }, + "end": { + "line": 5, + "col": 11 + }, + "type": "type x = Foo", + "tail": "no" + }, { "start": { "line": 5, diff --git a/tests/test-units/sherldoc/dune b/tests/test-units/sherldoc/dune index f84c9d6d2c..e6ebc33cfd 100644 --- a/tests/test-units/sherldoc/dune +++ b/tests/test-units/sherldoc/dune @@ -1,3 +1,4 @@ (test (name sherlodoc_test) + (package merlin-lib) (libraries fmt alcotest merlin-lib.sherlodoc))