Michelson-mode: async, cache, and refactorings

emacs/README.md

@@ -0,0 +1,56 @@
+# Michelson Emacs mode
+This mode is a work in progress.
+Please contact us with bugs and feature requests.
+All of the options mentioned below are also accessible via the customize menu.
+
+## Required Configuration
+To use the mode, you must load the `michelson-mode.el` file into Emacs.
+Add the following to your `.emacs` file.
+```elisp
+(load "~/tezos/tezos/emacs/michelson-mode.el" nil t)
+```
+
+Before using the Emacs mode, you must configure the `michelson-client-command`.
+If you have compiled the Tezos Git repository,
+set this to be the path to the `tezos-client` binary on your system.
+Make sure you have an up to date version of the client compiled.
+You must also start a tezos node to enable typechecking features.
+This option is recommended because it is faster than operating through
+the docker container.
+
+If you wish to run the Emacs mode with the alphanet script,
+use the path of the `alphanet.sh` script, plus the word `client`.
+You must also set the `michelson-alphanet` variable to be `t`.
+If you do not set this option, the mode will not work with the alphanet.
+
+Here are examples of the client configuration:
+### Without the alphanet
+```elisp
+(setq michelson-client-command "~/tezos/tezos/tezos-client")
+(setq michelson-alphanet nil)
+```
+### With the alphanet
+```elisp
+(setq michelson-client-command "~/tezos/alphanet/alphanet.sh client")
+(setq michelson-alphanet t)
+```
+
+## Additional Options
+There are various feature of the Emacs mode you may wish to configure.
+
+### Error display
+When writing a contract, you may wish to disable error display in order to
+avoid the "wrong stack type at end of body" error that is often present.
+This can be done by changing the
+`michelson-print-errors` and `michelson-highlight-errors` options.
+Both of these options also have interactive toggles for easy access.
+
+### Live printing
+You can disable live printing using the `michelson-live-editing` option.
+If this option is disabled, both type and error printing are supressed.
+No background command will be run, limiting the mode to syntax highlighting.
+This command can also be toggled interactively using the
+`michelson-toggle-live-editing` command.
+
+### Faces
+The highlighting colors used can be configured. See the customize menu for details.

emacs/michelson-mode.el

@@ -1,5 +1,7 @@
 ;; Major mode for editing Michelson smart contracts.
 
+(require 'cl)
+
 (defvar michelson-mode-hook nil)
 
 (defgroup michelson nil
@@ -12,7 +14,7 @@
   :prefix "michelson-"
   :group 'michelson)
 
-(defcustom michelson-mode-client-command "tezos-client"
+(defcustom michelson-client-command "tezos-client"
   "Path to the `tezos-client' binary."
   :type 'string
   :group 'michelson-options)
@@ -28,6 +30,21 @@
   :group 'michelson
   :group 'faces)
 
+(defcustom michelson-live-editing t
+  "Toggles live types and error printing.
+Overrides `michelson-print-errors' and `michelson-highlight-errors'"
+  :group 'michelson-options)
+
+(defcustom michelson-print-errors t
+  "Print the errors in the output buffer."
+  :type 'boolean
+  :group 'michelson-options)
+
+(defcustom michelson-highlight-errors t
+  "Highlight errors in the source buffer."
+  :type 'boolean
+  :group 'michelson-options)
+
 (defvar michelson-face-instruction
   'michelson-face-instruction
   "Face name for Michelson instructions.")
@@ -47,6 +64,7 @@
 (defvar michelson-face-constant
   'michelson-face-constant
   "Face name for Michelson constants.")
+
 (defface michelson-face-constant
    '((t (:inherit 'font-lock-constant-face)))
    "Face for Michelson constants."
@@ -68,9 +86,19 @@
    "Face for Michelson comments."
    :group 'michelson-faces)
 
+(defvar michelson-face-declaration
+  'michelson-face-declaration
+  "Face name for Michelson declarations.")
+
+(defface michelson-face-declaration
+   '((t (:inherit 'font-lock-keyword-face)))
+   "Face for Michelson constants."
+   :group 'michelson-faces)
+
 (defvar michelson-face-error
   'michelson-face-error
   "Face name for Michelson comments.")
+
 (defface michelson-face-error
   '(( ((class color) (background light)) (:background "MistyRose") )
     ( ((class color) (background dark)) (:background "DarkRed") ))
@@ -87,6 +115,14 @@
   (interactive)
   (customize-group-other-window `michelson-faces))
 
+(defun michelson-toggle-print-errors ()
+  (interactive)
+  (setq michelson-print-errors (not michelson-print-errors)))
+
+(defun michelson-highlight-errors ()
+  (interactive)
+  (setq michelson-highlight-errors (not michelson-highlight-errors)))
+
 (defconst michelson-mode-map
   (let ((michelson-mode-map (make-sparse-keymap)))
     ;; menu
@@ -125,6 +161,8 @@
     '("\\<[A-Z][a-z_0-9]+\\>" . michelson-face-constant)
     '("\\<[A-Z][A-Z_0-9]*\\>" . michelson-face-instruction)
     '("\\<\$[A-Za-z-_0-9]*\\>" . michelson-face-annotation)
+    ;; This will have problems if users have whitespace in front of the declarations
+    '("^parameter\\|^return\\|^storage\\|^code" . michelson-face-declaration)
     '("\\<[a-z][a-z_0-9]*\\>" . michelson-face-type))
    nil nil nil nil
    '(font-lock-syntactic-face-function . michelson-font-lock-syntactic-face-function)))
@@ -296,68 +334,157 @@
                 (michelson-goto-previous-token)))))
     (display-message-or-buffer message "*Michelson*")))
 
-(defun michelson-type-at-point ()
+(cl-defstruct cache
-  "Display the type of the expression under the cursor."
+  "Cache for types. Invalid entries are removed"
-  (interactive)
+  types
-  (let ((tmp-file (make-temp-file (buffer-name))))
+  errors)
+
+(defvar michelson-cached-buffer-info (make-cache :types '() :errors '()))
+
+(defvar michelson-process-output-buffer "*Michelson-process*")
+
+(defun michelson-erase-process-buffer ()
+  "Remove all text from process buffer."
+  (get-buffer-create michelson-process-output-buffer)
+  (with-current-buffer michelson-process-output-buffer
+    (erase-buffer)))
+
+(defun michelson-async-command-to-string (command callback)
+  "Asynchronously execute `COMMAND' and call the `CALLBACK' on the resulting string."
+  (lexical-let ((callback-fun callback))
+    (michelson-erase-process-buffer)
+    (set-process-sentinel
+     (start-process-shell-command
+      "michelson-shell-process"
+      michelson-process-output-buffer
+      command)
+     (lambda (process signal)
+       (let ((output
+              (with-current-buffer michelson-process-output-buffer
+                (buffer-string))))
+         (funcall callback-fun output))))))
+
+(defun michelson-clean-cache ()
+  "Clean the buffer's program info cache."
+  (let ((types (cache-types michelson-cached-buffer-info))
+        (errors (cache-errors michelson-cached-buffer-info))
+        (clean-cache-entry
+         (lambda (alist)
+           (remove-if (lambda (entry)
+                        (let ((tok-end (cadr entry)))
+                          (> tok-end (point))))
+                      alist))))
+    (setq michelson-cached-buffer-info
+          (make-cache :types (funcall clean-cache-entry types)
+                      :errors (funcall clean-cache-entry errors)))))
+
+(defun michelson-get-info (buffer-name)
+  "Refresh the info about the program in `BUFFER-NAME' from the command."
+  (lexical-let ((tmp-file (make-temp-file buffer-name)))
     (write-region (point-min) (point-max) tmp-file nil 'no-message)
-    (let* ((command (concat
+    (let ((command (concat
-                     (if michelson-alphanet "ALPHANET_EMACS=true " "")
+                    "ALPHANET_EMACS=true "
-                     michelson-mode-client-command
+                    "TEZOS_ALPHANET_DO_NOT_PULL=yes "
+                    michelson-client-command
                     " typecheck program "
+                    (let ((file-name
+                           (make-temp-file (buffer-name))))
+                      (write-region (point-min) (point-max) file-name nil 'no-message)
                       (if michelson-alphanet
-                         (concat "container:" buffer-file-name)
+                          (concat "container:" file-name)
-                       buffer-file-name)
+                        file-name))
-                     " -details -emacs"))
+                    " -details -emacs")))
-           (stdout
+      (michelson-async-command-to-string
-            (shell-command-to-string command))
+       command
-           (record
+       (lambda (output)
-            (car (read-from-string stdout)))
+         (condition-case err
-           (errors
+             (let*
-            (cdr (assoc 'errors record)))
+                 ((record (car (read-from-string output)))
-           (types
+                  (errors (cdr (assoc 'errors record)))
-            (cdr (assoc 'types record)))
+                  (types  (cdr (assoc 'types record))))
-           (message ""))
+               (setq michelson-cached-buffer-info (make-cache :types types :errors errors)))
-      (delete-file tmp-file)
+           ((error err)
-      (remove-overlays)
+            (let ((inhibit-message t))
-      (setq message "")
+              (message output)))))))))
-      (dolist (elt types)
+
-        (if (and (<= (car elt) (point)) (<= (point) (cadr elt))
+(defvar michelson-output-buffer-name
-                 (equal (get-text-property (point) 'face)
+  "*Michelson*")
-                        'michelson-face-instruction))
+
-            (setq message (cadr (cdr elt)))))
+(defun michelson-write-output-buffer (data)
-      (dolist (elt errors)
+  "Write the given `DATA' to the output buffer."
-        (overlay-put (make-overlay (car elt) (cadr elt)) 'face 'michelson-face-error)
+  (lexical-let*
-        (if (and (<= (car elt) (point)) (<= (point) (cadr elt)))
+      ((buffer (get-buffer-create michelson-output-buffer-name))
-            (progn
+       (message-window
-              (if (string= "" message)
+        (if (get-buffer-window buffer)
-                  nil
+            (get-buffer-window buffer)
-                (setq message (concat message "\n")))
+          (display-buffer-below-selected buffer nil)))
-              (setq message (concat message (cadr (cdr elt)))))))
-      (if (string= message "")
-          (setq message "\n  No instruction at point."))
-      (let
-          ((message-window
-            (display-buffer-below-selected
-             (get-buffer-create "*Michelson*") nil))
        (lines 0))
+    (when (get-buffer-window buffer)
+      (set-window-dedicated-p (get-buffer-window buffer) t))
     (save-excursion
-          (set-buffer "*Michelson*")
+      (set-buffer michelson-output-buffer-name)
-          (toggle-read-only nil)
+      (read-only-mode -1)
       (erase-buffer)
-          (insert message)
+      (insert data)
-          (toggle-read-only t)
+      (read-only-mode 1)
-          (beginning-of-buffer)
+      (goto-char (point-min))
       (while (not (eobp))
         (vertical-motion 1)
         (setq lines (+ 1 lines)))
       (window-resize
        message-window
+       (min (- (window-total-height) 5)
             (+ (- (max 4 lines)
-                 (window-size message-window)) 1)))))))
+                  (window-size message-window))
+               2))))))
+
+(defun michelson-show-program-info (types errors)
+  "Show the program's `TYPES' and `ERRORS'."
+  (interactive)
+  (remove-overlays)
+  (lexical-let ((types-info nil)
+                (errors-info nil))
+    (dolist (elt types)
+      (if (and (<= (car elt) (point)) (<= (point) (cadr elt))
+               (equal (get-text-property (point) 'face)
+                      'michelson-face-instruction))
+          (setq types-info (cadr (cdr elt)))))
+    (when michelson-highlight-errors
+      (dolist (elt errors)
+        (overlay-put (make-overlay (car elt) (cadr elt)) 'face 'michelson-face-error)
+        (if (and (<= (car elt) (point)) (<= (point) (cadr elt)))
+            (progn
+              (when michelson-print-errors
+                (unless errors-info
+                  (setq errors-info (concat errors-info "\n")))
+                (setq errors-info (concat errors-info (cadr (cdr elt)))))))))
+    (michelson-write-output-buffer
+     (cond ((not (or types-info types-info)) "\n  No instruction at point.\n")
+           ((and errors-info (not types-info)) errors-info)
+           (t (concat types-info "\n\n" errors-info))))))
+
+(defun michelson-type-at-point ()
+  "Display the type of the expression under the cursor."
+  (interactive)
+  (michelson-get-info (buffer-name))
+  (let ((types (cache-types michelson-cached-buffer-info))
+        (errors (cache-errors michelson-cached-buffer-info)))
+    (michelson-show-program-info types errors)))
+
+(defun michelson-toggle-live-editing ()
+  "Toggle `michelson-live-editing'.
+Enables or disables stack and error display."
+  (interactive)
+  (when (and michelson-live-editing
+             (get-buffer michelson-output-buffer-name))
+    (save-excursion
+      (set-buffer michelson-output-buffer-name)
+      (kill-buffer-and-window)))
+  (setq michelson-live-editing (not michelson-live-editing)))
 
 (defun michelson-update-minibuffer-info ()
-  (when (nth 2 michelson-state) (cancel-timer (nth 2 michelson-state)))
+  (when (nth 2 michelson-state)
+    (cancel-timer (nth 2 michelson-state)))
   (setf
    (nth 2 michelson-state)
    (run-at-time
@@ -365,7 +492,8 @@
     (lambda (buffer)
       (with-current-buffer buffer
         (setf (nth 2 michelson-state) nil)
-        (when (not (= (nth 0 michelson-state) (point)))
+        (when (and (not (= (nth 0 michelson-state) (point)))
+                   michelson-live-editing)
           (setf (nth 0 michelson-state) (point))
           (michelson-type-at-point))))
     (current-buffer))))
@@ -388,12 +516,16 @@
   (set
    (make-local-variable 'michelson-state)
    (list 0 0 nil))
+  (set (make-local-variable 'michelson-cached-buffer-info)
+       (make-cache :types nil
+                   :errors nil))
   (add-to-list
    (make-local-variable 'pre-command-hook)
    'michelson-update-minibuffer-info)
   (add-to-list
    (make-local-variable 'focus-in-hook)
    'michelson-update-minibuffer-info)
+  (add-hook 'post-self-insert-hook 'michelson-clean-cache)
   (setq major-mode 'michelson-mode)
   (setq mode-name "Michelson")
   (setq indent-tabs-mode nil)