From 6a4255424cbbfac3f3fd127238ff5029ce5ff385 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Wed, 31 Jan 2024 13:01:58 +0100 Subject: [PATCH] jump: add new command to navigate match statements --- CHANGES.md | 3 +- src/analysis/jump.ml | 53 ++++++++++++++-- tests/test-dirs/motion/jump_match.t | 93 +++++++++++++++++++++++++++++ 3 files changed, 143 insertions(+), 6 deletions(-) create mode 100644 tests/test-dirs/motion/jump_match.t diff --git a/CHANGES.md b/CHANGES.md index db6d0be252..01d4d9e491 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,9 +5,10 @@ merlin NEXT_VERSION - Add a "heap_mbytes" field to Merlin server responses to report heap usage (#1717) - Add cache stats to telemetry (#1711) - Add new SyntaxDocument command to find information about the node under the cursor (#1706) - - Fix `FLG -pp ppx.exe -as-pp/-dump-ast` use of invalid shell redirection when + - Fix `FLG -pp ppx.exe -as-pp/-dump-ast` use of invalid shell redirection when direct process launch on Windows. (#1723, fixes #1722) - Add a query_num field to the `ocamlmerlin` responses to detect server crashes (#1716) + - Jump to cases within a match statement (#1726) + editor modes - vim: load merlin under the ocamlinterface and ocamllex filetypes (#1340) - Fix merlinpp not using binary file open (#1725, fixes #1724) diff --git a/src/analysis/jump.ml b/src/analysis/jump.ml index 18063d0a36..c21c9861b1 100644 --- a/src/analysis/jump.ml +++ b/src/analysis/jump.ml @@ -32,6 +32,8 @@ open Std open Typedtree open Browse_raw +type direction = Prev | Next + let is_node_fun = function | Expression { exp_desc = Texp_function _; _ } -> true | _ -> false @@ -104,6 +106,8 @@ let rec find_map ~f = function exception No_matching_target exception No_predicate of string +exception No_next_match_case +exception No_prev_match_case (* Returns first node on the list matching a predicate *) let rec find_node preds nodes = @@ -127,6 +131,36 @@ let rec skip_non_moving pos = function | [] -> [] ;; +let get_cases_from_match node = + match node with + | Expression { exp_desc = Texp_match (_, cases, _); _ } -> cases + | _ -> [] + +let find_case_pos cases pos direction = + let rec find_pos pos cases direction = + match cases with + | [] -> None + | { c_lhs = { pat_loc; _ }; _ } :: tail -> + let check = + match direction with + | Prev -> + pos.Lexing.pos_cnum > pat_loc.loc_start.pos_cnum + | Next -> + pos.Lexing.pos_cnum < pat_loc.loc_start.pos_cnum + in + if check then + Some pat_loc.loc_start + else + find_pos pos tail direction + in + let case = find_pos pos cases direction in + match case with + | Some location -> `Found location + | None -> + (match direction with + | Next -> raise No_next_match_case + | Prev -> raise No_prev_match_case) + let get typed_tree pos target = let roots = Mbrowse.of_typedtree typed_tree in let enclosings = @@ -134,12 +168,13 @@ let get typed_tree pos target = | [] -> [] | l -> List.map ~f:snd l in - let all_preds = [ "fun", fun_pred; "let", let_pred; "module", module_pred; "match", match_pred; + "match-next-case", match_pred; + "match-prev-case", match_pred; ] in let targets = Str.split (Str.regexp "[, ]") target in try @@ -152,17 +187,25 @@ let get typed_tree pos target = in if String.length target = 0 then `Error "Specify target" - else begin + else let nodes = skip_non_moving pos enclosings in let node = find_node preds nodes in - let node_loc = Browse_raw.node_real_loc Location.none node in - `Found node_loc.Location.loc_start - end + match target with + | "match-next-case" -> find_case_pos (get_cases_from_match node) pos Next + | "match-prev-case" -> + find_case_pos (List.rev (get_cases_from_match node)) pos Prev + | _ -> + let node_loc = Browse_raw.node_real_loc Location.none node in + `Found node_loc.Location.loc_start with | No_predicate target -> `Error ("No predicate for " ^ target) | No_matching_target -> `Error "No matching target" + | No_next_match_case -> + `Error "No next case found" + | No_prev_match_case -> + `Error "No previous case found" let phrase typed_tree pos target = let roots = Mbrowse.of_typedtree typed_tree in diff --git a/tests/test-dirs/motion/jump_match.t b/tests/test-dirs/motion/jump_match.t new file mode 100644 index 0000000000..842d0ec09f --- /dev/null +++ b/tests/test-dirs/motion/jump_match.t @@ -0,0 +1,93 @@ + $ cat > test.ml << EOF + > let find_vowel x = + > match x with + > | 'A' -> + > true + > | 'E' -> + > true + > | 'I' -> + > true + > | 'O' -> + > true + > | 'U' -> + > true + > | _ -> + > false + > EOF + +Test if location of next case is given + $ $MERLIN single jump -target match-next-case -position 3:3 -filename test.ml < test.ml + { + "class": "return", + "value": { + "pos": { + "line": 5, + "col": 2 + } + }, + "notifications": [] + } + +Test if location of prev case is given + $ $MERLIN single jump -target match-prev-case -position 5:2 -filename test.ml < test.ml + { + "class": "return", + "value": { + "pos": { + "line": 3, + "col": 2 + } + }, + "notifications": [] + } + +Test when cursor is not in a match statement + $ $MERLIN single jump -target match-prev-case -position 1:2 -filename test.ml < test.ml + { + "class": "return", + "value": "No matching target", + "notifications": [] + } + + +Test when there's no next case + $ $MERLIN single jump -target match-next-case -position 13:2 -filename test.ml < test.ml + { + "class": "return", + "value": "No next case found", + "notifications": [] + } + +Test when there's no previous case + $ $MERLIN single jump -target match-prev-case -position 3:2 -filename test.ml < test.ml + { + "class": "return", + "value": "No previous case found", + "notifications": [] + } + +Test jump from case 'O' to the previous case + $ $MERLIN single jump -target match-prev-case -position 9:2 -filename test.ml < test.ml + { + "class": "return", + "value": { + "pos": { + "line": 7, + "col": 2 + } + }, + "notifications": [] + } + +Test jump from case 'O' to the next case + $ $MERLIN single jump -target match-next-case -position 9:2 -filename test.ml < test.ml + { + "class": "return", + "value": { + "pos": { + "line": 11, + "col": 2 + } + }, + "notifications": [] + }