diff --git a/src/kernel/mreader_lexer.ml b/src/kernel/mreader_lexer.ml index 28d77d2599..44571a2aac 100644 --- a/src/kernel/mreader_lexer.ml +++ b/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 diff --git a/src/ocaml/preprocess/lexer_ident.mll b/src/ocaml/preprocess/lexer_ident.mll index e9690dbd27..d10f3791fa 100644 --- a/src/ocaml/preprocess/lexer_ident.mll +++ b/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 | "[@@" | "[@@@" | "!" - | "!=" | "+" | "+." diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/run.t b/tests/test-dirs/locate/context-detection/cd-test.t/run.t index 867e37d011..e5fb445e8a 100644 --- a/tests/test-dirs/locate/context-detection/cd-test.t/run.t +++ b/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": [] } diff --git a/tests/test-dirs/locate/issue1915.t b/tests/test-dirs/locate/issue1915.t index f5481290fa..4e50781bef 100644 --- a/tests/test-dirs/locate/issue1915.t +++ b/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 + }