Improve location of some custom operators

src/kernel/mreader_lexer.ml

@@ -123,6 +123,12 @@ let comments t =
 
 open Parser_raw
 
+let pair_bracket = function
+  | '{' -> Some RBRACE
+  | '(' -> Some RPAREN
+  | '[' -> Some RBRACKET
+  | _ -> None
+
 let is_operator = function
   | PREFIXOP s
   | LETOP s
@@ -148,6 +154,20 @@ let is_operator = function
   | AMPERAMPER -> Some "&&"
   | COLONEQUAL -> Some ":="
   | PLUSEQ -> Some "+="
+  | DOTOP s -> (
+    let last = String.get s (String.length s - 1) in
+    match pair_bracket last with
+    | Some pair ->
+      (* note: this is a heuristic which ignores the difference between
+        the following three operators:
+          [.%( )]
+          [.%(;..)]
+          [.%(;..)<-]
+        It will always return the first one. Now, typically, if one
+        is defined, all are, with the same semantics, but this is
+        still unfortunate. *)
+      Some (s ^ Parser_printer.print_token pair)
+    | None -> Some s)
   | _ -> None
 
 (* [reconstruct_identifier] is impossible to read at the moment, here is a
@@ -233,6 +253,75 @@ let reconstruct_identifier_from_tokens tokens pos =
     (* LIDENT always begin a new identifier *)
     | ((LIDENT _, _, _) as item) :: items ->
       if acc = [] then look_for_dot [ item ] items else check acc (item :: items)
+    (* Reified custom indexing operators *)
+    (* e.g. [( .%(;..) )] *)
+    | (RPAREN, _, _)
+      :: (token, _, tend)
+      :: (DOTDOT, _, _)
+      :: (SEMI, _, _)
+      :: (DOTOP s, tstart, _)
+      :: (LPAREN, _, _)
+      :: items
+      when acc = [] -> (
+      let last = String.get s (String.length s - 1) in
+      match pair_bracket last with
+      | Some pair when pair = token ->
+        let item =
+          (DOTOP (s ^ ";.." ^ Parser_printer.print_token pair), tstart, tend)
+        in
+        look_for_dot [ item ] items
+      | _ -> check acc items)
+    (* e.g. [( .%(;..)<- )] *)
+    | (RPAREN, _, _)
+      :: (LESSMINUS, _, tend)
+      :: (token, _, _)
+      :: (DOTDOT, _, _)
+      :: (SEMI, _, _)
+      :: (DOTOP s, tstart, _)
+      :: (LPAREN, _, _)
+      :: items
+      when acc = [] -> (
+      let last = String.get s (String.length s - 1) in
+      match pair_bracket last with
+      | Some pair when pair = token ->
+        let item =
+          ( DOTOP (s ^ ";.." ^ Parser_printer.print_token pair ^ "<-"),
+            tstart,
+            tend )
+        in
+        look_for_dot [ item ] items
+      | _ -> check acc items)
+    (* e.g. [( .%( ) )] *)
+    | (RPAREN, _, _)
+      :: (token, _, tend)
+      :: (DOTOP s, tstart, _)
+      :: (LPAREN, _, _)
+      :: items
+      when acc = [] -> (
+      let last = String.get s (String.length s - 1) in
+      match pair_bracket last with
+      | Some pair when pair = token ->
+        let item =
+          (DOTOP (s ^ Parser_printer.print_token pair), tstart, tend)
+        in
+        look_for_dot [ item ] items
+      | _ -> check acc items)
+    (* e.g. [( .%( )<- )] *)
+    | (RPAREN, _, _)
+      :: (LESSMINUS, _, tend)
+      :: (token, _, _)
+      :: (DOTOP s, tstart, _)
+      :: (LPAREN, _, _)
+      :: items
+      when acc = [] -> (
+      let last = String.get s (String.length s - 1) in
+      match pair_bracket last with
+      | Some pair when pair = token ->
+        let item =
+          (DOTOP (s ^ Parser_printer.print_token pair ^ "<-"), tstart, tend)
+        in
+        look_for_dot [ item ] items
+      | _ -> check acc items)
     (* Reified operators behave like LIDENT *)
     | (RPAREN, _, _) :: ((token, _, _) as item) :: (LPAREN, _, _) :: items
       when is_operator token <> None && acc = [] -> look_for_dot [ item ] items

src/ocaml/preprocess/lexer_ident.mll

@@ -93,7 +93,15 @@ rule token = parse
   | "'"  { QUOTE }
   | "("  { LPAREN }
   | ")"  { RPAREN }
+  | "}"  { RBRACE }
+  | "]"  { RBRACKET }
+  | ".." { DOTDOT }
+  | "<-" { LESSMINUS }
+  | ";"  { SEMI }
+  | "." dotsymbolchar+ ['(' '{' '[' ]
+         { DOTOP(Lexing.lexeme lexbuf) }
   | "."  { DOT }
+  | ":=" { COLONEQUAL }
   | "!" symbolchar +
             { PREFIXOP(Lexing.lexeme lexbuf) }
   | ['~' '?'] symbolchar +
@@ -144,12 +152,9 @@ rule token = parse
   | "*"
   | ","
   | "->"
-  | ".."
   | ":"
   | "::"
-  | ":="
   | ":>"
-  | ";"
   | ";;"
   | "<"
   | "<-"
@@ -174,7 +179,6 @@ rule token = parse
   | "[@@"
   | "[@@@"
   | "!"
-
   | "!="
   | "+"
   | "+."

tests/test-dirs/locate/context-detection/cd-test.t/run.t

@@ -74,12 +74,16 @@ This should say "Already at definition point" (we're defining the label):
     "notifications": []
   }
 
-FIXME we failed to parse/reconstruct the ident, that's interesting
-
   $ $MERLIN single locate -look-for ml -position 16:16 -filename ./test.ml < ./test.ml
   {
     "class": "return",
-    "value": "Not a valid identifier",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 13,
+        "col": 11
+      }
+    },
     "notifications": []
   }
 

tests/test-dirs/locate/issue1915.t

@@ -7,12 +7,18 @@ Testing the behavior of custom operators
   > EOF
 
   $ $MERLIN single locate -look-for ml -position 2:17 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not a valid identifier"
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 1,
+    "col": 4
+  }
 
   $ $MERLIN single locate -look-for ml -position 3:12 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not a valid identifier"
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 1,
+    "col": 4
+  }
 
 Testing custom indexing operators
 
@@ -22,37 +28,71 @@ Testing custom indexing operators
   > let name = "baz"
   > let () = name.%{2;4}
   > let () = name.%{5}
+  > let () = ( .%{;..} ) name 7
   > let () = ( .%{ } ) name 3
   > EOF
 
+Should be on line 1
   $ $MERLIN single locate -look-for ml -position 4:15 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not in environment '%'"
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 4
+  }
 
   $ $MERLIN single locate -look-for ml -position 4:16 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not a valid identifier"
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 4
+  }
 
+  $ $MERLIN single locate -look-for ml -position 6:13 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 1,
+    "col": 4
+  }
+
+  $ $MERLIN single locate -look-for ml -position 6:14 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 1,
+    "col": 4
+  }
+
+  $ $MERLIN single locate -look-for ml -position 6:15 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 1,
+    "col": 4
+  }
+
+Should be on line 2
   $ $MERLIN single locate -look-for ml -position 5:15 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not in environment '%'"
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 4
+  }
 
   $ $MERLIN single locate -look-for ml -position 5:15 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not in environment '%'"
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 4
+  }
 
   $ $MERLIN single locate -look-for ml -position 5:16 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not a valid identifier"
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 4
+  }
 
-  $ $MERLIN single locate -look-for ml -position 6:13 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not in environment '%'"
-
-  $ $MERLIN single locate -look-for ml -position 6:14 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not a valid identifier"
-
-  $ $MERLIN single locate -look-for ml -position 6:15 \
-  > -filename ./main.ml < ./main.ml | jq '.value'
-  "Not a valid identifier"
+  $ $MERLIN single locate -look-for ml -position 7:15 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 4
+  }