Merge pull request #216 from rgrinberg/dev

Emacs mode renovation

.gitignore

@@ -1,3 +1,4 @@
 _build/
 .merlin
 *.install
+*.elc

src/top/utop.el

@@ -1,4 +1,4 @@
-;;; utop.el --- Universal toplevel for OCaml
+;;; utop.el --- Universal toplevel for OCaml -*- lexical-binding: t -*-
 
 ;; Copyright: (c) 2011, Jeremie Dimino <jeremie@dimino.org>
 ;; Author: Jeremie Dimino <jeremie@dimino.org>
@@ -18,9 +18,8 @@
 ;;; Code:
 
 (require 'easymenu)
-
+(require 'pcase)
-;; tabulated-list is a part of Emacs 24
+(require 'tabulated-list)
-(require 'tabulated-list nil t)
 
 ;; +-----------------------------------------------------------------+
 ;; | License                                                         |
@@ -238,19 +237,20 @@ Caml toplevel")
 (defun utop-compat-resolve (choices)
   "Resolve a symbol based on the current major mode. CHOICES is a
 list of 3 function symbols: (tuareg-symbol typerex-symbol caml-symbol)."
-  (cond
+  (nth
-   ((eq major-mode 'tuareg-mode  ) (nth 0 choices))
+   (pcase major-mode
-   ((eq major-mode 'typerex-mode ) (nth 1 choices))
+     ('tuareg-mode 0)
-   ((eq major-mode 'caml-mode    ) (nth 2 choices))
+     ('typerex-mode 1)
-   ((eq major-mode 'reason-mode  ) (nth 3 choices))
+     ('caml-mode 2)
-   (t (error (format "utop doesn't support the major mode \"%s\". It
+     ('reason-mode 3)
-supports caml, tuareg and typerex modes by default. For other
+     (major-mode (error (format "utop doesn't support the major mode \"%s\". It
+supports caml, tuareg, typerex and reason modes by default. For other
 modes you need to set these variables:
 
 - `utop-next-phrase-beginning'
 - `utop-discover-phrase'
-"
+" major-mode))))
-                     (symbol-name major-mode))))))
+   choices))
 
 (defun utop-compat-next-phrase-beginning ()
   (funcall
@@ -266,54 +266,6 @@ modes you need to set these variables:
                           caml-find-phrase
                           reason-discover-phrase))))
 
-;; +-----------------------------------------------------------------+
-;; | Compability with previous emacs version                         |
-;; +-----------------------------------------------------------------+
-
-(unless (featurep 'tabulated-list)
-  ;; tabulated-list.el is part of Emacs 24
-  ;; This is a thin layer building compability with previous versions
-  (defvar tabulated-list-format nil)
-  (defvar tabulated-list-sort-key nil)
-  (defvar tabulated-list-printer nil)
-  (defvar tabulated-list-revert-hook nil)
-  (defvar tabulated-list-entries nil)
-  (define-derived-mode tabulated-list-mode special-mode "Mini-tabulated list mode"
-    "Tabulated list"
-    (make-local-variable 'tabulated-list-format)
-    (make-local-variable 'tabulated-list-sort-key)
-    (make-local-variable 'tabulated-list-printer)
-    (set (make-local-variable 'revert-buffer-function) 'tabulated-list-revert)
-
-  (defun tabulated-list-init-header ()
-    (save-excursion
-      (let ((inhibit-read-only t))
-            (mapc
-             (lambda (entry)
-               (let* ((name (nth 0 entry))
-                      (size (length name))
-                      (padding (- (nth 1 entry) size)))
-                 (insert name)
-                 (insert-char ?\s padding)
-                 )) tabulated-list-format)
-            (insert "\n"))))
-
-  (defun tabulated-list-print (dummy)
-    (save-excursion
-      (let ((inhibit-read-only t))
-        (mapc (lambda (entry)
-                (goto-char (point-max))
-                (apply tabulated-list-printer entry))
-              tabulated-list-entries))
-      t))
-
-  (defun tabulated-list-revert (ignore-auto noconfirm)
-    (let ((inhibit-read-only t))
-      (delete-region (point-min) (point-max))
-      (tabulated-list-init-header)
-      (tabulated-list-print t))))
-)
-
 ;; +-----------------------------------------------------------------+
 ;; | Utils                                                           |
 ;; +-----------------------------------------------------------------+
@@ -356,34 +308,25 @@ it is started."
   "Change the utop state and mode-line-process."
   (setq utop-state state)
   (setq mode-line-process
-        (cond
+        (pcase state
-         ((eq state 'edit)
+          ('edit ": idle")
-          ": idle")
+          ('comp ": completion")
-         ((eq state 'comp)
+          ('hist ": history")
-          ": completion")
+          ('wait ": running")
-         ((eq state 'hist)
+          ('copy ": copying")
-          ": history")
+          ('done
-         ((eq state 'wait)
+           (let ((status (process-status utop-process))
-          ": running")
+                 (code (process-exit-status utop-process)))
-         ((eq state 'copy)
-          ": copying")
-         ((eq state 'done)
-          (let ((status (process-status utop-process)) (code (process-exit-status utop-process)))
              (cond
               ((and (eq status 'exit) (= code 0))
                ": exited[0]")
-             ((eq status 'exit)
+              ((or (eq status 'exit) (eq status 'signal))
-              (let ((msg (concat ": exited[" (int-to-string code) "]")))
+               (let* ((status-name (pcase status ('exit "exited") ('signal "killed")))
+                      (msg (concat ": " status-name "[" (int-to-string code) "]")))
                  (add-text-properties 0 (length msg) '(face bold) msg)
                  msg))
-             ((eq status 'signal)
+              (t ": unknown"))))
-              (let ((msg (concat ": killed[" (int-to-string code) "]")))
+          (_ ": unknown"))))
-                (add-text-properties 0 (length msg) '(face bold) msg)
-                msg))
-             (t
-              ": unknown"))))
-         (t
-          ": unknown"))))
 
 (defun utop-send-data (cmd)
   "Send current input to utop"
@@ -434,33 +377,30 @@ it is started."
         (end-pos (utop-ident-looking nil)))
     (buffer-substring-no-properties start-pos end-pos)))
 
-; Currently not working - the communication is asynchronous so how to
+;; Currently not working - the communication is asynchronous so how to
-; make sure without implementing another state that the type
+;; make sure without implementing another state that the type
-; information has been already printed?
+;; information has been already printed?
 (defun utop-type-at-point ()
   "Find type of an identifier at point from uTop"
-  (utop-eval-string (utop-ident-at-point))
+  (utop-eval-string (utop-ident-at-point)))
-  ;  (utop-last-type)
+;;  (utop-last-type)
-  )
+
 
 ;; +-----------------------------------------------------------------+
 ;; | Edition control                                                 |
 ;; +-----------------------------------------------------------------+
 
 (defun utop-cannot-edit ()
-  (cond
+  (signal
-   ((eq utop-state 'wait)
+   'text-read-only
-    (signal 'text-read-only '("You cannot edit the buffer while ocaml is evaluating a phrase")))
+   (pcase utop-state
-   ((eq utop-state 'done)
+     ('wait "You cannot edit the buffer while ocaml is evaluating a phrase")
-    (signal 'text-read-only '("You cannot edit the buffer when ocaml is not running")))
+     ('done "You cannot edit the buffer when ocaml is not running")
-   ((eq utop-state 'comp)
+     ('comp "You cannot edit the buffer while waiting for completion")
-    (signal 'text-read-only '("You cannot edit the buffer while waiting for completion")))
+     ('copy "You cannot edit the buffer while waiting for copy of last input")
-   ((eq utop-state 'copy)
+     ('hist "You cannot edit the buffer while waiting for history"))))
-    (signal 'text-read-only '("You cannot edit the buffer while waiting for copy of last input")))
-   ((eq utop-state 'hist)
-    (signal 'text-read-only '("You cannot edit the buffer while waiting for history")))))
 
-(defun utop-before-change (start stop)
+(defun utop-before-change (_start stop)
   (unless utop-inhibit-check
     (cond
      ((not (eq utop-state 'edit))
@@ -585,18 +525,18 @@ it is started."
   ;; Extract the command and its argument
   (string-match "\\`\\([a-z-]*\\):\\(.*\\)\\'" line)
   (let ((command (match-string 1 line)) (argument (match-string 2 line)))
-    (cond
+    (pcase command
       ;; Output on stdout
-     ((string= command "stdout")
+      ("stdout"
        (utop-insert-output argument 'utop-stdout))
       ;; Output on stderr
-     ((string= command "stderr")
+      ("stderr"
        (utop-insert-output argument 'utop-stderr))
       ;; Synchronisation of the phrase terminator
-     ((string= command "phrase-terminator")
+      ("phrase-terminator"
        (setq utop-phrase-terminator argument))
       ;; A new prompt
-     ((string= command "prompt")
+      ("prompt"
        (let ((prompt (apply utop-prompt ())))
          ;; Insert the new prompt
          (utop-insert-prompt prompt)
@@ -610,7 +550,7 @@ it is started."
            (utop-eval-input nil t nil utop-initial-mode)
            (setq utop-initial-mode nil))))
       ;; Input has been accepted
-     ((string= command "accept")
+      ("accept"
        ;; Add a newline character at the end of the buffer
        (goto-char (point-max))
        (insert "\n")
@@ -631,7 +571,7 @@ it is started."
        (setq utop-prompt-min (point-max))
        (setq utop-prompt-max (point-max)))
       ;; Continue editiong
-     ((string= command "continue")
+      ("continue"
        ;; Add a newline character at the position where the user
        ;; pressed enter
        (when utop-pending-position
@@ -640,14 +580,14 @@ it is started."
        ;; Reset the state
        (utop-set-state 'edit))
       ;; Part of a history entry
-     ((string= command "history-data")
+      ("history-data"
        (cond
         (utop-pending-entry
          (setq utop-pending-entry (concat utop-pending-entry "\n" argument)))
         (t
          (setq utop-pending-entry argument))))
       ;; End of history data
-     ((string= command "history-end")
+      ("history-end"
        (progn
          (cond
           ((eq utop-state 'copy)
@@ -661,23 +601,23 @@ it is started."
          ;; Resume edition
          (utop-set-state 'edit)))
       ;; We are at a bound of history
-     ((string= command "history-bound")
+      ("history-bound"
        ;; Just resume edition
        (utop-set-state 'edit))
       ;; Complete with a word
-     ((string= command "completion-word")
+      ("completion-word"
        (utop-set-state 'edit)
        (with-current-buffer utop-complete-buffer (insert argument))
        ;; Hide completion
        (minibuffer-hide-completions))
       ;; Start of completion
-     ((string= command "completion-start")
+      ("completion-start"
        (setq utop-completion nil))
       ;; A new possible completion
-     ((string= command "completion")
+      ("completion"
        (push argument utop-completion))
       ;; End of completion
-     ((string= command "completion-stop")
+      ("completion-stop"
        (utop-set-state 'edit)
        (if (> (length utop-completion) 1)
            (with-current-buffer utop-complete-buffer
@@ -686,7 +626,7 @@ it is started."
          (minibuffer-hide-completions))
        (setq utop-completion nil)))))
 
-(defun utop-process-output (process output)
+(defun utop-process-output (_process output)
   "Process the output of utop"
   (with-current-buffer utop-buffer-name
     (utop-perform
@@ -931,7 +871,7 @@ defaults to 0."
     (unless (eq utop-state 'done)
       (utop-send-string (format "exit:%d\n" (or exit-code 0))))))
 
-(defun utop-sentinel (process msg)
+(defun utop-sentinel (_process _msg)
   "Callback for process' state change."
   (let ((buffer (get-buffer utop-buffer-name)))
     ;; Do nothing if the buffer does not exist anymore
@@ -1008,7 +948,7 @@ defaults to 0."
       (setq packages (cdr packages))))
   (setq tabulated-list-entries (nreverse tabulated-list-entries)))
 
-(defun utop-package-printer (id cols)
+(defun utop-package-printer (_id cols)
   "Print one findlib package entry."
   (let ((width (cadr (elt tabulated-list-format 0))))
     (insert-text-button (elt cols 0)