Add naive support for Papply in reconstruct identifier

This treat an application as a single components so it is not a satisfing long-term solution.

A better approach would be to change the return type of [reconstruct_identifier] to account for module application.

This fixes #1610

src/kernel/mreader_lexer.ml

@@ -28,6 +28,8 @@
 
 open Std
 
+let {Logger. log} = Logger.for_section "mreader_lexer"
+
 type keywords = Lexer_raw.keywords
 
 type triple = Parser_raw.token * Lexing.position * Lexing.position
@@ -223,6 +225,15 @@ let is_operator = function
  »
 *)
 
+let print_token fmt = function
+ | LIDENT s -> Format.fprintf fmt "LIDENT %s" s
+ | UIDENT s -> Format.fprintf fmt "UIDENT %s" s
+ | LPAREN -> Format.fprintf fmt "LPAREN"
+ | RPAREN -> Format.fprintf fmt "RPAREN"
+ | DOT -> Format.fprintf fmt "DOT"
+ | EOF -> Format.fprintf fmt "EOF"
+ | _ -> Format.fprintf fmt "OTHER";;
+
 let reconstruct_identifier_from_tokens tokens pos =
  let rec look_for_component acc = function
 
@@ -246,6 +257,36 @@ let reconstruct_identifier_from_tokens tokens pos =
  when is_operator token <> None && acc = [] ->
  look_for_dot [item] items
 
+ (* RPAREN UIDENT means that we are in presence of a functor application. *)
+ | (RPAREN, _, end_pos) :: ((UIDENT _, _, _ ) as item) :: items
+ when acc <> [] ->
+ let param_items, items = group_until_lparen [item] items in
+ begin try
+ begin try
+ (* Is the cursor on the parameter ? *)
+ look_for_dot [] (List.rev param_items)
+ with Not_found ->
+ (* Is the cursor on the functor or before ? *)
+ look_for_component [] items
+ end
+ with Not_found ->
+ (* The cursor must be after the application [M.N(F).|t]
+ We make a single component with the applciation and continue *)
+ match items with
+ | (UIDENT f, start_pos, _ ) :: items ->
+ let app =
+ let param = List.map ~f:(function
+ | (DOT, _, _ ) -> "."
+ | (UIDENT s, _, _) -> s
+ | _ -> raise Not_found
+ ) param_items
+ in
+ Format.sprintf "%s(%s)" f (String.concat ~sep:"" param)
+ in
+ look_for_dot ((UIDENT app, start_pos, end_pos ) :: acc) items
+ | _ -> raise Not_found
+ end
+
  (* An operator alone is an identifier on its own *)
  | (token, _, _ as item) :: items
  when is_operator token <> None && acc = [] ->
@@ -257,6 +298,11 @@ let reconstruct_identifier_from_tokens tokens pos =
 
  | [] -> raise Not_found
 
+ and group_until_lparen acc = function
+ | (LPAREN,_,_) :: items -> acc, items
+ | item :: items -> group_until_lparen (item::acc) items
+ | _ -> raise Not_found
+
  and look_for_dot acc = function
  | (DOT,_,_) :: items -> look_for_component acc items
  | items -> check acc items
@@ -312,6 +358,9 @@ let reconstruct_identifier config source pos =
  let lexbuf = Lexing.from_string (Msource.text source) in
  Location.init lexbuf (Mconfig.filename config);
  let tokens = lex [] lexbuf in
+ log ~title:"from_tokens" "%a" Logger.fmt (fun fmt ->
+ Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
+ (fun fmt (tok, _, _) -> print_token fmt tok) fmt tokens);
  reconstruct_identifier_from_tokens tokens pos
 
 let is_uppercase {Location. txt = x; _} =

tests/test-dirs/locate/issue1610.t

@@ -3,42 +3,63 @@
  > type 'a t
  > end
  > 
- > module M (T : T) = struct
- > type t = int T.t
+ > module N = struct
+ > module M (T : T) = struct
+ > type t = int T.t
+ > end
  > end
  > 
- > module T = struct type 'a t end
+ > module F = struct
+ > module T = struct type 'a t end
+ > end
  > 
- > type t = M(T).t
+ > type u = N.M(F.T).t
  > EOF
 
-FIXME: we should jump to the functor's body, not the current definition
-This is due to an issue with identifier-reconstruction
- $ $MERLIN single locate -look-for ml -position 11:15 \
- > -filename main.ml <main.ml 
+We should jump to the functor's body (line 7)
+ $ $MERLIN single locate -look-for ml -position 15:18 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 7,
+ "col": 4
+ }
+
+Should jump to T's definition (line 12)
+ $ $MERLIN single locate -look-for ml -position 15:15 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 12,
+ "col": 2
+ }
+
+Should jump to F's definition (line 11)
+ $ $MERLIN single locate -look-for ml -position 15:13 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 11,
+ "col": 0
+ }
+
+Should jump to M's definition (line 6)
+ $ $MERLIN single locate -look-for ml -position 15:11 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 6,
+ "col": 2
+ }
+
+Should jump to N's definition (line 5)
+ $ $MERLIN single locate -look-for ml -position 15:9 \
+ > -filename main.ml <main.ml | jq '.value.pos'
  {
- "class": "return",
- "value": {
- "file": "$TESTCASE_ROOT/main.ml",
- "pos": {
- "line": 11,
- "col": 0
- }
- },
- "notifications": []
+ "line": 5,
+ "col": 0
  }
 
-It works as expected when the user inputs the expression manually
- $ $MERLIN single locate -prefix 'M(T).t' -look-for ml -position 11:15 \
- > -filename main.ml <main.ml 
+It also works as expected when the user inputs the expression manually
+ $ $MERLIN single locate -prefix 'N.M(F.T).t' -look-for ml -position 15:18 \
+ > -filename main.ml <main.ml | jq '.value.pos'
  {
- "class": "return",
- "value": {
- "file": "$TESTCASE_ROOT/main.ml",
- "pos": {
- "line": 6,
- "col": 2
- }
- },
- "notifications": []
+ "line": 7,
+ "col": 4
  }