utop.el

;; utop.el
;; -------
;; Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
;; Licence   : BSD3
;;
;; This file is a part of utop.

;; +-----------------------------------------------------------------+
;; | Customizable variables                                          |
;; +-----------------------------------------------------------------+

(defgroup utop nil
  "A toplevel for the ocaml programming language which interact
with Emacs to provide an enhanced environment."
  :tag "The Caml Emacs-Lisp Toplevel"
  :version "1.0"
  :group 'applications)

(defcustom utop-command "utop-emacs"
  "The command to execute for utop."
  :type 'string
  :group 'utop)

(defcustom utop-prompt 'utop-default-prompt
  "The function which create the prompt for utop."
  :type 'function
  :group 'utop)

(defcustom utop-mode-hook nil
  "A hook that gets run when `utop-mode' is entered."
  :type 'hook
  :group 'utop)

(defcustom utop-exit-hook nil
  "A hook that is run whenever `utop' is exited.
This hook is only run if exiting actually kills the buffer."
  :type 'hook
  :group 'utop)

(defface utop-prompt
  '((t (:foreground "Cyan1")))
  "The face used to highlight the prompt."
  :group 'utop)

(defface utop-stdout
  nil
  "The face used to highlight messages comming from stdout."
  :group 'utop)

(defface utop-stderr
  nil
  "The face used to highlight messages commong from stderr."
  :group 'utop)

(defface utop-frozen
  '((t (:bold t)))
  "The face used to highlight text that has been sent to utop.")

;; +-----------------------------------------------------------------+
;; | Constants                                                       |
;; +-----------------------------------------------------------------+

(defconst utop-buffer-name "*utop*"
  "The name of the buffer utop is running on.")

;; +-----------------------------------------------------------------+
;; | Variables                                                       |
;; +-----------------------------------------------------------------+

(defvar utop-process nil
  "The Lisp-object for the utop sub-process")

(defvar utop-mode-map nil
  "The utop local keymap.")

(defvar utop-prompt-min 0
  "The point at the beginning of the current prompt.")

(defvar utop-prompt-max 0
  "The point at the end of the current prompt.")

(defvar utop-last-prompt 0
  "The contents of the last displayed prompt.")

(defvar utop-output ""
  "The output of the utop sub-process not yet processed.")

(defvar utop-command-number 0
  "The number of the current command.")

(defvar utop-history nil
  "The history of typed command.")

(defvar utop-history-prev nil
  "The history before the cursor.")

(defvar utop-history-next nil
  "The history after the cursor.")

(defvar utop-pending nil
  "The text not yet added to the history.")

(defvar utop-completion nil
  "Current completion.")

(defvar utop-move-to-end-of-buffer nil
  "Whether to move the point to the end of prompt after
displaying the prompt")

;; +-----------------------------------------------------------------+
;; | Utils                                                           |
;; +-----------------------------------------------------------------+

(defun utop-add-text-properties-rear-nonsticky (start end properties nonsticky-properties &optional object)
  "Same as ``add-text-properties'' but put the last character in
non-sticky mode."
  (when (< start end)
    ;; Put everything between start and end-1 in sticky read-only mode
    (add-text-properties start (- end 1) properties object)
    ;; Put the last character in non-sticky mode
    (add-text-properties (- end 1) end
                         (append
                          properties
                          (list 'rear-nonsticky nonsticky-properties))
                         object)))

;; +-----------------------------------------------------------------+
;; | Prompt                                                          |
;; +-----------------------------------------------------------------+

(defun utop-default-prompt ()
  "The default prompt function."
  (let ((prompt (format "utop[%d]> " utop-command-number)))
    (add-text-properties 0 (length prompt) '(face utop-prompt) prompt)
    prompt))

;; +-----------------------------------------------------------------+
;; | History                                                         |
;; +-----------------------------------------------------------------+

(defun utop-history-goto-prev ()
  "Go to the previous entry of the history."
  (interactive)
  (unless (null utop-history-prev)
    (with-current-buffer utop-buffer-name
      ;; Push current input after the history cursor
      (push (delete-and-extract-region utop-prompt-max (point-max)) utop-history-next)
      ;; Go to after the prompt to insert the previous input
      (goto-char utop-prompt-max)
      ;; Pop one element from history before the cursor and insert it
      (insert (pop utop-history-prev)))))

(defun utop-history-goto-next ()
  "Go to the next entry of the history."
  (interactive)
  (unless (null utop-history-next)
    (with-current-buffer utop-buffer-name
      ;; Push current input before the history cursor
      (push (delete-and-extract-region utop-prompt-max (point-max)) utop-history-prev)
      ;; Go to after the prompt to insert the next input
      (goto-char utop-prompt-max)
      ;; Pop one element from history after the cursor and insert it
      (insert (pop utop-history-next)))))

;; +-----------------------------------------------------------------+
;; | Receiving input from the utop sub-process                     |
;; +-----------------------------------------------------------------+

(defun utop-insert-output (output &optional face)
  "Insert the given output before the prompt."
  (with-current-buffer utop-buffer-name
    (save-excursion
      (let ((line (concat output "\n")))
        ;; Make the line read-only
        (add-text-properties 0 (length line) '(read-only t) line)
        ;; Apply the given face if provided
        (when face (add-text-properties 0 (length line) (list 'face face) line))
        ;; Goto before the prompt
        (goto-char utop-prompt-min)
        ;; Insert the output
        (let ((inhibit-read-only t)) (insert line))
        ;; Advance the prompt
        (setq utop-prompt-min (+ utop-prompt-min (length line)))
        (setq utop-prompt-max (+ utop-prompt-max (length line)))))))

(defun utop-insert-prompt (prompt)
  "Insert the given prompt."
  (with-current-buffer utop-buffer-name
    ;; Make the old prompt sticky so we cannot edit after it
    (let ((inhibit-read-only t))
      (remove-text-properties utop-prompt-min utop-prompt-max '(rear-nonsticky nil)))
    ;; Make the prompt read-only. Make the read-only property
    ;; non-sticky so the buffer can be edited after the prompt
    (utop-add-text-properties-rear-nonsticky 0 (length prompt) '(read-only t) '(face read-only) prompt)
    ;; Goto the end of the buffer
    (goto-char (point-max))
    ;; Make it the start of the prompt
    (setq utop-prompt-min (point))
    ;; Insert the prompt
    (let ((inhibit-read-only t)) (insert prompt))
    ;; Set the end of prompt
    (setq utop-prompt-max (point))))

(defun utop-process-line (line)
  "Process one line from the utop sub-process."
  ;; Extract the command and its argument
  (string-match "\\`\\([a-z-]*\\):\\(.*\\)\\'" line)
  (let ((command (match-string 1 line)) (argument (match-string 2 line)))
    (cond
     ;; Output on stdout
     ((string= command "stdout")
      (utop-insert-output argument 'utop-stdout))
     ;; Output on stderr
     ((string= command "stderr")
      (utop-insert-output argument 'utop-stderr))
     ;; A new prompt
     ((string= command "prompt")
      (let ((prompt (apply utop-prompt ())))
        ;; Check whether there is something to push to the history
        (if (stringp utop-pending)
            ;; Push pending input to the history if it is different
            ;; from the top of the history
            (unless (and (consp utop-history) (string= utop-pending (car utop-history)))
              (push utop-pending utop-history)))
        ;; Clear pending input
        (setq utop-pending nil)
        ;; Reset history
        (setq utop-history-prev utop-history)
        (setq utop-history-next nil)
        ;; Save current prompt
        (setq utop-last-prompt prompt)
        ;; Insert the new prompt
        (utop-insert-prompt prompt)
        ;; Increment the command number
        (setq utop-command-number (+ utop-command-number 1))
        ;; Move the point to the end of buffer in all utop windows if
        ;; needed
        (when utop-move-to-end-of-buffer
          (setq utop-move-to-end-of-buffer nil)
          (let ((buffer (current-buffer)))
            (walk-windows
             (lambda (window)
               (when (eq (window-buffer window) buffer)
                 (select-window window)
                 (goto-char (point-max)))))))))
     ;; Continuation of previous input
     ((string= command "continue")
      ;; Reset history
      (setq utop-history-prev utop-history)
      (setq utop-history-next nil)
      ;; Insert the last prompt
      (utop-insert-prompt utop-last-prompt))
     ;; Complete with a word
     ((string= command "completion-word")
      (insert argument))
     ;; Start of completion
     ((string= command "completion-start")
      (setq utop-completion nil))
     ;; A new possible completion
     ((string= command "completion")
      (setq utop-completion (cons argument utop-completion)))
     ;; End of completion
     ((string= command "completion-stop")
      (with-output-to-temp-buffer "*Completions*"
        (display-completion-list (nreverse utop-completion)))
      (setq utop-completion nil)))))

(defun utop-process-output (process output)
  "Process the output of utop"
  (with-current-buffer utop-buffer-name
    ;; Concatenate the output with the output not yet processed
    (setq utop-output (concat utop-output output))
    ;; Split lines. Each line contains exactly one command
    (let ((lines (split-string utop-output "\n")))
      (while (>= (length lines) 2)
        ;; Process the first line
        (utop-process-line (car lines))
        ;; 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
      (setq utop-output (car lines)))))

;; +-----------------------------------------------------------------+
;; | Sending data to the utop sub-process                            |
;; +-----------------------------------------------------------------+

(defun utop-send-input ()
  "Send the text typed at current prompt to the utop
sub-process."
  (interactive)
  (with-current-buffer utop-buffer-name
    ;; Push input to pending input
    (let ((input (buffer-substring-no-properties utop-prompt-max (point-max))))
      (if (stringp utop-pending)
          (setq utop-pending (concat utop-pending "\n" input))
        (setq utop-pending input))
      ;; Goto the end of the buffer
      (goto-char (point-max))
      ;; Terminate input by a newline
      (insert "\n")
      (let ((start utop-prompt-max) (stop (point-max)))
        ;; Make the text read-only
        (add-text-properties start stop '(read-only t))
        ;; Make the old prompt sticky so we cannot edit after it
        (let ((inhibit-read-only t))
          (remove-text-properties utop-prompt-min utop-prompt-max '(rear-nonsticky nil)))
        ;; Makes the text sent read only and add it the frozen face.
        (let ((inhibit-read-only t))
          (add-text-properties start stop '(read-only t face utop-frozen)))
        ;; Move the prompt to the end of the buffer
        (setq utop-prompt-min stop)
        (setq utop-prompt-max stop)
        ;; Send all lines to utop
        (let ((lines (split-string input "\n")))
          (process-send-string utop-process "input:\n")
          (while (consp lines)
            ;; Send the line
            (process-send-string utop-process (concat "data:" (car lines) "\n"))
            ;; Remove it and continue
            (setq lines (cdr lines)))
          (process-send-string utop-process "end:\n"))))))

;; +-----------------------------------------------------------------+
;; | Completion                                                      |
;; +-----------------------------------------------------------------+

(defun utop-complete ()
  "Complete current input."
  (interactive)
  ;; Complete only if the cursor is after the prompt
  (if (>= (point) utop-prompt-max)
      ;; Extract the input before the cursor
      (let ((input (buffer-substring-no-properties utop-prompt-max (point))))
        ;; Split it
        (let ((lines (split-string input "\n")))
          ;; Send all lines to utop
          (process-send-string utop-process "complete:\n")
          (while (consp lines)
            ;; Send the line
            (process-send-string utop-process (concat "data:" (car lines) "\n"))
            ;; Remove it and continue
            (setq lines (cdr lines)))
          (process-send-string utop-process "end:\n")))))

;; +-----------------------------------------------------------------+
;; | Tuareg integration                                              |
;; +-----------------------------------------------------------------+

(defun utop-start ()
  "Start utop if not already started."
  ;; Create the utop buffer if it does not exists, otherwise just
  ;; retreive it
  (let ((buf (get-buffer-create utop-buffer-name)))
    ;; Make it appear
    (display-buffer buf)
    ;; Set the utop mode in that buffer if not already done
    (with-current-buffer buf (unless (eq major-mode 'utop-mode) (utop-mode)))))

(defun utop-eval-region (start end)
  "Eval the current region in utop."
  (interactive "r")
  ;; Start utop if needed
  (save-excursion (utop-start))
  ;; From tuareg
  (setq tuareg-interactive-last-phrase-pos-in-source start)
  ;; Select the text of the region
  (let ((text
         (save-excursion
           ;; Search the start and end of the current paragraph
           (goto-char start)
           (tuareg-skip-blank-and-comments)
           (setq start (point))
           (goto-char end)
           (tuareg-skip-to-end-of-phrase)
           (setq end (point))
           (buffer-substring-no-properties start end))))
    (with-current-buffer utop-buffer-name
      ;; Insert it at the end of the utop buffer
      (goto-char (point-max))
      (insert text ";;")
      ;; Move the point to the end of buffer in all utop windows
      (let ((buffer (current-buffer)))
        (walk-windows
         (lambda (window)
           (when (eq (window-buffer window) buffer)
             (select-window window)
             (goto-char (point-max))))))
      ;; Make sure the cursor is after the prompt when the prompt
      ;; reappear
      (setq utop-move-to-end-of-buffer t)
      ;; Send input to utop now
      (utop-send-input))))

(defun utop-eval-phrase ()
  "Eval the surrounding Caml phrase (or block) in utop."
  (interactive)
  (let ((end))
    (save-excursion
      (let ((pair (tuareg-discover-phrase)))
	(setq end (nth 2 pair))
	(utop-eval-region (nth 0 pair) (nth 1 pair))))
    (if tuareg-skip-after-eval-phrase
	(goto-char end))))

(defun utop-eval-buffer ()
  "Send the buffer to utop."
  (interactive)
  (utop-eval-region (point-min) (point-max)))

;; +-----------------------------------------------------------------+
;; | Edition functions                                               |
;; +-----------------------------------------------------------------+

(defun utop-bol ()
  "Go to the beginning of line or to the end of the prompt."
  (interactive)
  (with-current-buffer utop-buffer-name
    (if (= (point-at-bol) utop-prompt-min)
        (goto-char utop-prompt-max)
      (move-beginning-of-line 1))))

;; +-----------------------------------------------------------------+
;; | The mode                                                        |
;; +-----------------------------------------------------------------+

(defun utop-mode ()
  "Caml Emacs-Lisp Toplevel.

\\{utop-mode-map}"

  ;; Local variables
  (make-local-variable 'utop-mode-map)
  (make-local-variable 'utop-process)
  (make-local-variable 'utop-prompt-min)
  (make-local-variable 'utop-prompt-max)
  (make-local-variable 'utop-last-prompt)
  (make-local-variable 'utop-output)
  (make-local-variable 'utop-command-number)
  (make-local-variable 'utop-history)
  (make-local-variable 'utop-history-prev)
  (make-local-variable 'utop-history-next)
  (make-local-variable 'utop-pending)

  ;; Set the major mode
  (setq major-mode 'utop-mode)
  (setq mode-name "utop")

  ;; Create and use the local keymap utop-mode-map
  (setq utop-mode-map (make-sparse-keymap))
  (use-local-map utop-mode-map)

  ;; Create the sub-process
  (setq utop-process (start-process "utop" (current-buffer) utop-command))

  ;; Filter the output of the sub-process with our filter function
  (set-process-filter utop-process 'utop-process-output)

  ;; Define keys
  (define-key utop-mode-map [return] 'utop-send-input)
  (define-key utop-mode-map [(control ?m)] 'utop-send-input)
  (define-key utop-mode-map [(control ?j)] 'utop-send-input)
  (define-key utop-mode-map [home] 'utop-bol)
  (define-key utop-mode-map [(control ?a)] 'utop-bol)
  (define-key utop-mode-map [(meta ?p)] 'utop-history-goto-prev)
  (define-key utop-mode-map [(meta ?n)] 'utop-history-goto-next)
  (define-key utop-mode-map [tab] 'utop-complete)

  ;; Register the exit hook
  (add-hook 'kill-buffer-hook (lambda () (run-hooks 'utop-exit-hook)) t t)

  ;; Call hooks
  (run-mode-hooks 'utop-mode-hook))

;; +-----------------------------------------------------------------+
;; | Starting utop                                                   |
;; +-----------------------------------------------------------------+

;;;###autoload
(defun utop ()
  "Start utop."
  (interactive)
  ;; Create the utop buffer if it does not exists, otherwise just
  ;; retreive it
  (let ((buf (get-buffer-create utop-buffer-name)))
    ;; Jump to that buffer
    (pop-to-buffer buf)
    ;; Set the utop mode in that buffer if not already done
    (unless (eq major-mode 'utop-mode) (utop-mode))
    ;; Finally return it
    buf))

(provide 'utop)