#606: reimplement merlin-phrase-{next,prev}

emacs/merlin.el

@@ -1241,6 +1241,29 @@ Empty string defaults to jumping to all these."
   (interactive "sfun, let, module or match > ")
   (merlin--goto-file-and-point (merlin/jump target)))
 
+(defun merlin/phrase (target)
+  "Move to next phrase (TARGET = 'next) or previous phrase (TARGET = 'prev)"
+  (if (or (not target) (equal target ""))
+    (setq target "fun let module match"))
+  (let ((result (merlin/call "phrase"
+                 "-position" (merlin/unmake-point (point))
+                 "-target" target)))
+    (unless result
+      (error "Not found. (Check *Messages* for potential errors)"))
+    (unless (listp result)
+      (error result))
+    result))
+
+(defun merlin-phrase-next ()
+  "Go to the beginning of the next phrase."
+  (interactive)
+  (merlin--goto-file-and-point (merlin/phrase 'next)))
+
+(defun merlin-phrase-prev ()
+  "Go to the beginning of the previous phrase."
+  (interactive)
+  (merlin--goto-file-and-point (merlin/phrase 'prev)))
+
 ;;;;;;;;;;;;;;
 ;; DOCUMENT ;;
 ;;;;;;;;;;;;;;

src/analysis/jump.ml

@@ -165,3 +165,56 @@ let get typed_tree pos target =
   | No_matching_target ->
     `Error "No matching target"
 
+let phrase typed_tree pos target =
+  let roots = Mbrowse.of_typedtree typed_tree in
+  (* Select nodes around cursor.
+     If the cursor is around a module expression, also search inside it. *)
+  let enclosing = match Mbrowse.enclosing pos [roots] with
+    | (env, (Browse_raw.Module_expr _ as node)) :: enclosing ->
+      Browse_raw.fold_node (fun env node enclosing -> (env,node) :: enclosing)
+        env node enclosing
+    | enclosing -> enclosing
+  in
+  (* Drop environment, they are of no use here *)
+  let enclosing = List.map ~f:snd enclosing in
+  let find_item x xs = match target with
+    | `Prev -> List.rev (List.take_while ~f:((!=)x) xs)
+    | `Next -> match List.drop_while ~f:((!=)x) xs with _::xs -> xs | [] -> []
+  in
+  let find_pos prj xs =
+    match target with
+    | `Prev ->
+      let f x = Location_aux.compare_pos pos (prj x) > 0 in
+      List.rev (List.take_while ~f xs)
+    | `Next ->
+      let f x = Location_aux.compare_pos pos (prj x) >= 0 in
+      List.drop_while ~f xs
+  in
+  let rec seek_item = function
+    | [] -> None
+    | Browse_raw.Signature xs :: tail ->
+      begin match find_pos (fun x -> x.Typedtree.sig_loc) xs.Typedtree.sig_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.sig_loc
+      end
+    | Browse_raw.Structure xs :: tail ->
+      begin match find_pos (fun x -> x.Typedtree.str_loc) xs.Typedtree.str_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.str_loc
+      end
+    | Browse_raw.Signature_item (x,_) :: Browse_raw.Signature xs :: tail ->
+      begin match find_item x xs.Typedtree.sig_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.sig_loc
+      end
+    | Browse_raw.Structure_item (x,_) :: Browse_raw.Structure xs :: tail ->
+      begin match find_item x xs.Typedtree.str_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.str_loc
+      end
+    | _ :: xs -> seek_item xs
+  in
+  match seek_item enclosing, target with
+  | Some loc, _ -> `Logical (Lexing.split_pos loc.Location.loc_start)
+  | None, `Prev -> `Start
+  | None, `Next -> `End

src/analysis/jump.mli

@@ -31,3 +31,8 @@ val get :
   Mtyper.typedtree ->
   Std.Lexing.position ->
   string -> [> `Error of string | `Found of Lexing.position ]
+
+val phrase :
+  Mtyper.typedtree ->
+  Std.Lexing.position ->
+  [< `Next | `Prev ] -> [> `End | `Logical of int * int | `Start ]

src/frontend/new/new_commands.ml

@@ -242,6 +242,33 @@ let all_commands = [
     end
   ;
 
+  command "phrase"
+    ~doc:"phrase -target [next|prev] -position pos\n\t\
+          TODO"
+    ~spec: [
+      ("-target",
+       "<next|prev> Entity to jump to",
+       Marg.param "string" (fun target (_,pos) ->
+           match target with
+           | "next" -> (`Next,pos)
+           | "prev" -> (`Prev,pos)
+           | _ -> failwith "-target should be one of 'next' or 'prev'"
+         )
+      );
+      ("-position",
+       "<position> Position to complete",
+       marg_position (fun pos (target,_pos) -> (target,pos))
+      );
+    ]
+    ~default:(`Next,`None)
+    begin fun buffer (target,pos) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Phrase (target,pos))
+    end
+  ;
+
   command "list-modules"
     ~doc:"list-modules -ext .ml -ext .mli ...\n\t\
           looks into project source paths for files with an extension \

src/frontend/query_commands.ml

@@ -437,6 +437,13 @@ let dispatch buffer (type a) : a Query_protocol.t -> a =
     let pos = Msource.get_lexing_pos (Mpipeline.input_source pipeline) pos in
     Jump.get typedtree pos target
 
+  | Phrase (target, pos) ->
+    with_typer buffer @@ fun pipeline typer ->
+    let source = Mpipeline.input_source pipeline in
+    let typedtree = Mtyper.get_typedtree typer in
+    let pos = Msource.get_lexing_pos source pos in
+    Msource.get_lexing_pos source (Jump.phrase typedtree pos target)
+
   | Case_analysis (pos_start, pos_end) ->
     with_typer buffer @@ fun pipeline typer ->
     let source = Mpipeline.input_source pipeline in

src/frontend/query_json.ml

@@ -104,6 +104,11 @@ let dump (type a) : a t -> json =
       "target", `String target;
       "position", mk_position pos;
     ]
+  | Phrase (target, pos) ->
+    mk "phrase" [
+      "target", `String (match target with `Next -> "next" | `Prev -> "prev");
+      "position", mk_position pos;
+    ]
   | Case_analysis (pos_start,pos_end) ->
     mk "case-analysis" [
       "start", mk_position pos_start;
@@ -280,6 +285,8 @@ let json_of_response (type a) (query : a t) (response : a) : json =
       | `Found pos ->
         `Assoc ["pos", Lexing.json_of_position pos]
     end
+  | Phrase _, pos ->
+    `Assoc ["pos", Lexing.json_of_position pos]
   | Case_analysis _, ({ Location. loc_start ; loc_end }, str) ->
     let assoc =
       `Assoc [

src/frontend/query_protocol.ml

@@ -119,6 +119,9 @@ type _ t =
     -> [ `Found of Lexing.position
        | `Error of string
        ] t
+  | Phrase(* *)
+    : [`Next | `Prev] * Msource.position
+    -> Lexing.position t
   | Case_analysis(* *)
     : Msource.position * Msource.position -> (Location.t * string) t
   | Outline(* *)

vim/merlin/autoload/merlin.py

@@ -134,7 +134,7 @@ def merlin_exec(*args, input=""):
 
 def command(*args, context=None):
     (filename, content) = context or current_context()
-    cmdline = ["server"] + list(args) + ["--","-filename",filename] + \
+    cmdline = ["server"] + list(args) + ["-filename",filename] + \
             concat_map(lambda ext: ("-extension",ext), vim_list_if_set("b:merlin_extensions")) + \
             concat_map(lambda pkg: ("-package",pkg), vim_list_if_set("b:merlin_packages")) + \
             vim.eval('g:merlin_binary_flags') + \
@@ -250,9 +250,9 @@ def command_locate(path, pos):
     except MerlinExc as e:
         try_print_error(e)
 
-def command_jump(target, pos):
+def command_motion(cmd, target, pos):
     try:
-        pos_or_err = command("jump", "-target", target, "-position", fmtpos(pos))
+        pos_or_err = command(cmd, "-target", target, "-position", fmtpos(pos))
         if not isinstance(pos_or_err, dict):
             print(pos_or_err)
         else:
@@ -261,7 +261,10 @@ def command_jump(target, pos):
             # save the current position in the jump list
             vim.command("normal! m'")
             # TODO: move the cursor using vimscript, so we can :keepjumps?
-            vim.current.window.cursor = (l, c)
+            try:
+                vim.current.window.cursor = (l, c)
+            except:
+                vim.command("$")
     except MerlinExc as e:
         try_print_error(e)
 
@@ -358,13 +361,19 @@ def vim_locate_at_cursor(path):
 def vim_locate_under_cursor():
     vim_locate_at_cursor(None)
 
-# Jump
+# Jump and Phrase motion
 def vim_jump_to(target):
-    command_jump(target, vim.current.window.cursor)
+    command_motion("jump", target, vim.current.window.cursor)
 
 def vim_jump_default():
   vim_jump_to("fun let module match")
 
+def vim_phrase_prev():
+    command_motion("phrase", "prev", vim.current.window.cursor)
+
+def vim_phrase_next():
+    command_motion("phrase", "next", vim.current.window.cursor)
+
 # Document
 def vim_document_at_cursor(path):
     command_document(path, vim.current.window.cursor)
@@ -611,11 +620,12 @@ def vim_which(name,exts):
     return command('path-of-source', *files)
 
 def vim_which_ext(exts,vimvar):
-    files = command('list-modules', *concat_map(lambda ext: ("-ext",ext)))
+    files = command('list-modules', *concat_map(lambda ext: ("-ext",ext), exts))
     vim.command("let %s = []" % vimvar)
     for f in sorted(set(files)):
         vim.command("call add(%s, '%s')" % (vimvar, f))
 
+# Options listing
 def vim_flags_list(vimvar):
     for x in command('flags-list'):
         vim.command("call add(%s, '%s')" % (vimvar, x))

vim/merlin/autoload/merlin.vim

@@ -348,6 +348,14 @@ function! merlin#Jump(...)
   endif
 endfunction
 
+function! merlin#PhrasePrev()
+  MerlinPy merlin.vim_phrase_prev()
+endfunction
+
+function! merlin#PhraseNext()
+  MerlinPy merlin.vim_phrase_next()
+endfunction
+
 function! merlin#Document(...)
   if (a:0 > 1)
     echoerr "Document: to many arguments (expected 0 or 1)"
@@ -519,8 +527,12 @@ function! merlin#Register()
     nmap <silent><buffer> gd  :MerlinLocate<return>
   endif
 
-  """ Jump  ------------------------------------------------------------------
+  """ Jump and Phrase motion ---------------------------------------------------
   command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinJump call merlin#Jump(<q-args>)
+  command! -buffer MerlinPhrasePrev call merlin#PhrasePrev()
+  command! -buffer MerlinPhraseNext call merlin#PhraseNext()
+  nmap <silent><buffer> [[ :MerlinPhrasePrev<cr>
+  nmap <silent><buffer> ]] :MerlinPhraseNext<cr>
 
   """ Document  ----------------------------------------------------------------
   command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinDocument call merlin#Document(<q-args>)