Merge pull request #233 from rgrinberg/company-mode

Company mode

src/lib/uTop_main.ml

@@ -992,6 +992,18 @@ module Emacs(M : sig end) = struct
             loop_commands history_prev history_next
           else
             loop ()
+      | Some ("complete-company", _) ->
+        let input = read_data () in
+        let _, words =
+          UTop_complete.complete
+            ~syntax:(UTop.get_syntax ())
+            ~phrase_terminator:(UTop.get_phrase_terminator ())
+            ~input
+        in
+        send "completion-start" "";
+        List.iter (fun (w, _) -> send "completion" w) words;
+        send "completion-stop" "";
+        loop_commands history_prev history_next
       | Some ("complete", _) ->
           let input = read_data () in
           let start, words =
@@ -1308,10 +1320,13 @@ let load_inputrc () =
       Lwt_log.error_f "error in key bindings file %S, line %d: %s" fname line msg
     | exn -> Lwt.fail exn)
 
+let protocol_version = 1
+
 let main_aux ~initial_env =
   Arg.parse args file_argument usage;
   if not (prepare ()) then exit 2;
   if !emacs_mode then begin
+    Printf.printf "protocol-version:%d\n%!" protocol_version;
     UTop_private.set_ui UTop_private.Emacs;
     let module Emacs = Emacs (struct end) in
     Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version;

src/top/utop.el

@@ -230,6 +230,26 @@ end-pos-with-comments)." )
 Non-nil means skip to the end of the phrase after evaluation in the
 Caml toplevel")
 
+(defvar utop--complete-k (lambda (_candidates) '())
+  "continuation function to populate the candidates for the company
+backend")
+
+(defvar utop-protocol-version "0"
+  "detected version of utop protocol. 0 for unknown or version pre")
+
+(defvar utop--read-version nil
+  "whether we've tried to detect the utop version")
+
+(defvar utop--company-loaded nil)
+
+(defun utop--supports-company ()
+  (and
+   ;; version< only works on version numbers 
+   (condition-case nil
+       (version<= "1" utop-protocol-version)
+     (error t))
+   (featurep 'company)))
+
 ;; +-----------------------------------------------------------------+
 ;; | Compability with different ocaml major modes                    |
 ;; +-----------------------------------------------------------------+
@@ -334,11 +354,9 @@ it is started."
     (setq utop-input-prompt-max utop-prompt-max)
     ;; Send all lines to utop
     (utop-send-string cmd)
-    (while lines
+    (dolist (line lines)
       ;; Send the line
-      (utop-send-string (concat "data:" (car lines) "\n"))
+      (utop-send-string (concat "data:" line "\n")))
-      ;; Remove it and continue
-      (setq lines (cdr lines)))
     (utop-send-string "end:\n")))
 
 (defun utop-last-type ()
@@ -619,11 +637,14 @@ it is started."
       ;; End of completion
       ("completion-stop"
        (utop-set-state 'edit)
-       (if (> (length utop-completion) 1)
+       (if (utop--supports-company)
-           (with-current-buffer utop-complete-buffer
+           (funcall utop--complete-k (nreverse utop-completion))
-             (with-output-to-temp-buffer "*Completions*"
+         (progn
-               (display-completion-list (nreverse utop-completion))))
+           (if (> (length utop-completion) 1)
-         (minibuffer-hide-completions))
+               (with-current-buffer utop-complete-buffer
+                 (with-output-to-temp-buffer "*Completions*"
+                   (display-completion-list (nreverse utop-completion))))
+             (minibuffer-hide-completions))))
        (setq utop-completion nil)))))
 
 (defun utop-process-output (_process output)
@@ -635,10 +656,19 @@ it is started."
      ;; Split lines. Each line contains exactly one command
      (let ((lines (split-string utop-output "\n")))
        (while (>= (length lines) 2)
-         ;; Process the first line
+         ;; process first line. if we haven't tried reading the version, we'll
-         (utop-process-line (car lines))
+         ;; trying to do it now.
-         ;; Remove it and continue
+         (let ((line (car lines)))
-         (setq lines (cdr lines)))
+           (if utop--read-version
+               (utop-process-line line)
+             (progn
+               (save-match-data
+                 (if (string-match "protocol-version:\\([0-9]+\\)" line)
+                     (setq utop-protocol-version (match-string 1 line))
+                   (utop-process-line line)))
+               (setq utop--read-version t)))
+           ;; Remove it and continue
+           (setq lines (cdr lines))))
        ;; When the list contains only one element, then this is either
        ;; the end of commands, either an unterminated one, so we save
        ;; it for later
@@ -711,12 +741,13 @@ If ADD-TO-HISTORY is t then the input will be added to history."
     ;; We are now waiting for completion
     (utop-set-state 'comp)
     ;; Send all lines to utop
-    (utop-send-string "complete:\n")
+    (utop-send-string
-    (while lines
+     (if (utop--supports-company)
+         "complete-company:\n"
+       "complete:\n"))
+    (dolist (line lines)
       ;; Send the line
-      (utop-send-string (concat "data:" (car lines) "\n"))
+      (utop-send-string (concat "data:" line "\n")))
-      ;; Remove it and continue
-      (setq lines (cdr lines)))
     (utop-send-string "end:\n")))
 
 (defun utop-complete ()
@@ -939,13 +970,12 @@ defaults to 0."
     ;; Set the header column size to the maximal length
     (setcdr (elt tabulated-list-format 0) (list max-name-length t))
     ;; Build a list, accumulating in tabulated-list-entries
-    (while packages
+    (dolist (package packages)
-      (let* ((package (car packages))
+      (let* ((package package)
              (name (car package))
              (version (cdr package)))
         (push (list package (vector name version))
-              tabulated-list-entries))
+              tabulated-list-entries))))
-      (setq packages (cdr packages))))
   (setq tabulated-list-entries (nreverse tabulated-list-entries)))
 
 (defun utop-package-printer (_id cols)
@@ -1121,6 +1151,10 @@ See https://github.com/diml/utop for configuration information."))
   (make-local-variable 'utop-phrase-terminator)
   (make-local-variable 'utop-pending-position)
   (make-local-variable 'utop-pending-entry)
+  (make-local-variable 'utop-protocol-version)
+
+  (make-local-variable 'utop--complete-k)
+  (make-local-variable 'utop--read-version)
 
   ;; Set the hook to call before changing the buffer
   (add-hook 'before-change-functions 'utop-before-change nil t)
@@ -1131,6 +1165,10 @@ See https://github.com/diml/utop for configuration information."))
   ;; Save history before killing the buffer
   (add-hook 'kill-buffer-query-functions (lambda () (utop-save-history) t) nil t)
 
+  ;; add company completion hook:
+  (with-eval-after-load 'company
+    (add-to-list 'company-backends #'utop-company-backend))
+
   ;; Start utop
   (utop-start (utop-arguments)))
 ;; +-----------------------------------------------------------------+
@@ -1177,6 +1215,20 @@ Special keys for utop:
         (with-current-buffer buf (utop-mode)))))
     buf))
 
+(defun utop-company-backend (command &optional _arg &rest ignored)
+  "company backend for utop completions"
+  (interactive (list 'interactive))
+  (pcase command
+    ('interactive (company-begin-backend 'utop-company-backend))
+    ('sorted t)
+    ('prefix (company-grab-symbol))
+    ('candidates
+     (progn
+       `(:async
+         . ,(lambda (k)
+              (setq utop--complete-k k)
+              (call-interactively #'utop-complete)))))))
+
 (provide 'utop-minor-mode)
 (provide 'utop)