590 lines
21 KiB
EmacsLisp
590 lines
21 KiB
EmacsLisp
;; 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.")
|
|
|
|
(defconst utop-non-editable-properties '(read-only t rear-nonsticky (read-only face))
|
|
"List of text properties for the non-editable part of the buffer")
|
|
|
|
;; +-----------------------------------------------------------------+
|
|
;; | 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-inhibit-check nil
|
|
"When set to a non-nil value, always insert text, even if it is
|
|
before the end of prompt.")
|
|
|
|
(defvar utop-state nil
|
|
"State of utop. It is one of:
|
|
|
|
- edit: the user is typing a command
|
|
- comp: waiting for completion
|
|
- wait: ocaml is evaluating a phrase
|
|
- done: ocaml has died.")
|
|
|
|
;; +-----------------------------------------------------------------+
|
|
;; | Utils |
|
|
;; +-----------------------------------------------------------------+
|
|
|
|
(defmacro utop-perform (&rest actions)
|
|
"Execute the given actions while checks are inhibited."
|
|
(list 'let (list (list 'utop-inhibit-check t) (list 'inhibit-read-only t)) (cons 'progn actions)))
|
|
|
|
(defun utop-insert (&rest args)
|
|
"Insert text with checks inhibited."
|
|
(utop-perform (apply 'insert args)))
|
|
|
|
(defun utop-goto-point-max-all-windows ()
|
|
"Move the point to the end of buffer in all utop windows."
|
|
(let ((buffer (get-buffer utop-buffer-name)))
|
|
(walk-windows
|
|
(lambda (window)
|
|
(when (eq (window-buffer window) buffer)
|
|
(select-window window)
|
|
(goto-char (point-max)))))))
|
|
|
|
;; +-----------------------------------------------------------------+
|
|
;; | Edition control |
|
|
;; +-----------------------------------------------------------------+
|
|
|
|
(defun utop-cannot-edit ()
|
|
(cond
|
|
((eq utop-state 'wait)
|
|
(signal 'text-read-only '("You cannot edit the buffer while ocaml is evaluating a phrase")))
|
|
((eq utop-state 'done)
|
|
(signal 'text-read-only '("You cannot edit the buffer when ocaml is not running")))
|
|
((eq utop-state 'comp)
|
|
(signal 'text-read-only '("You cannot edit the buffer while waiting for completion")))))
|
|
|
|
(defun utop-check-edit ()
|
|
(with-current-buffer utop-buffer-name
|
|
(unless (eq utop-state 'edit)
|
|
(utop-cannot-edit))))
|
|
|
|
(defun utop-before-change (start stop)
|
|
(unless utop-inhibit-check
|
|
(cond
|
|
((not (eq utop-state 'edit))
|
|
(add-hook 'post-command-hook 'utop-add-change nil t)
|
|
(utop-cannot-edit))
|
|
((< stop utop-prompt-max)
|
|
(utop-cannot-edit "You cannot edit this part of the buffer")))))
|
|
|
|
(defun utop-add-change ()
|
|
(remove-hook 'post-command-hook 'utop-add-change t)
|
|
(add-hook 'before-change-functions 'utop-before-change nil t))
|
|
|
|
;; +-----------------------------------------------------------------+
|
|
;; | 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)
|
|
(with-current-buffer utop-buffer-name
|
|
(when (and (eq utop-state 'edit) utop-history-prev)
|
|
;; 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)
|
|
(with-current-buffer utop-buffer-name
|
|
(when (and (eq utop-state 'edit) utop-history-next)
|
|
;; 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")))
|
|
;; 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
|
|
(insert line)
|
|
;; Advance the prompt
|
|
(setq utop-prompt-min (+ utop-prompt-min (length line)))
|
|
(setq utop-prompt-max (+ utop-prompt-max (length line)))
|
|
;; Make everything before the end prompt read-only
|
|
(add-text-properties (point-min) utop-prompt-max utop-non-editable-properties)))))
|
|
|
|
(defun utop-insert-prompt (prompt)
|
|
"Insert the given prompt."
|
|
(with-current-buffer utop-buffer-name
|
|
;; 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
|
|
(insert prompt)
|
|
;; Set the end of prompt
|
|
(setq utop-prompt-max (point))
|
|
;; Make everything before the end prompt read-only
|
|
(add-text-properties (point-min) utop-prompt-max utop-non-editable-properties)
|
|
;; We are now editing
|
|
(setq utop-state 'edit)
|
|
;; Move the point to the end of buffer in all utop windows
|
|
(utop-goto-point-max-all-windows)))
|
|
|
|
(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))))
|
|
;; 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")
|
|
(setq utop-state 'edit)
|
|
(insert argument))
|
|
;; Start of completion
|
|
((string= command "completion-start")
|
|
(setq utop-completion nil))
|
|
;; A new possible completion
|
|
((string= command "completion")
|
|
(push argument utop-completion))
|
|
;; End of completion
|
|
((string= command "completion-stop")
|
|
(setq utop-state 'edit)
|
|
(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
|
|
(utop-perform
|
|
;; 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
|
|
(when (eq utop-state 'edit)
|
|
(utop-perform
|
|
;; We are now waiting for ocaml
|
|
(setq utop-state 'wait)
|
|
;; 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")
|
|
;; Move the point to the end of buffer of all utop windows
|
|
(utop-goto-point-max-all-windows)
|
|
;; Make everything read-only
|
|
(add-text-properties (point-min) (point-max) utop-non-editable-properties)
|
|
(let ((start utop-prompt-max) (stop (point-max)))
|
|
;; Set the frozen face for the text we just sent.
|
|
(add-text-properties start stop '(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
|
|
(when (and (eq utop-state 'edit) (>= (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")))
|
|
;; We are now waiting for completion
|
|
(setq utop-state 'comp)
|
|
;; 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))
|
|
;; Check that we can send command now
|
|
(utop-check-edit)
|
|
;; 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 ";;")
|
|
;; Send input to utop now
|
|
(utop-send-input))))
|
|
|
|
(defun utop-eval-phrase ()
|
|
"Eval the surrounding Caml phrase (or block) in utop."
|
|
(interactive)
|
|
;; Start utop if needed
|
|
(save-excursion (utop-start))
|
|
;; Check that we can send command now
|
|
(utop-check-edit)
|
|
;; Locate the near phrase and eval it
|
|
(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))))
|
|
|
|
;; +-----------------------------------------------------------------+
|
|
;; | Process control |
|
|
;; +-----------------------------------------------------------------+
|
|
|
|
(defun utop-interrupt ()
|
|
"Interrupt utop."
|
|
(interactive)
|
|
(with-current-buffer utop-buffer-name
|
|
(interrupt-process utop-process)))
|
|
|
|
(defun utop-kill ()
|
|
"Kill utop."
|
|
(interactive)
|
|
(with-current-buffer utop-buffer-name
|
|
(kill-process utop-process)))
|
|
|
|
(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
|
|
(when buffer
|
|
(with-current-buffer utop-buffer-name
|
|
(let ((status (process-status utop-process)))
|
|
(when (or (eq status 'exit) (eq status 'signal))
|
|
;; The process is terminated
|
|
(setq utop-state 'done)
|
|
(let ((exit-code (process-exit-status utop-process)))
|
|
(utop-perform
|
|
;; Insert a message at the end
|
|
(goto-char (point-max))
|
|
(cond
|
|
((eq status 'exit)
|
|
(insert "\n\nProcess utop exited with code " (number-to-string exit-code) "\n"))
|
|
((eq status 'signal)
|
|
(insert "\n\nProcess utop has been killed by signal " (number-to-string exit-code) "\n")))
|
|
;; Go to the end of the buffer
|
|
(goto-char (point-max))
|
|
;; Make the whole buffer read-only
|
|
(add-text-properties (point-min) (point-max) utop-non-editable-properties)))))))))
|
|
|
|
;; +-----------------------------------------------------------------+
|
|
;; | 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)
|
|
(make-local-variable 'utop-inhibit-check)
|
|
(make-local-variable 'utop-state)
|
|
|
|
;; 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)
|
|
|
|
;; Set the initial state: we are waiting for ocaml to send the
|
|
;; initial prompt
|
|
(setq utop-state 'wait)
|
|
|
|
;; 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)
|
|
|
|
;; Set the process sentinel
|
|
(set-process-sentinel utop-process 'utop-sentinel)
|
|
|
|
;; Set the hook to call before changing the buffer
|
|
(add-hook 'before-change-functions 'utop-before-change nil t)
|
|
|
|
;; 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)
|
|
(define-key utop-mode-map [(control ?c) (control ?c)] 'utop-interrupt)
|
|
(define-key utop-mode-map [(control ?c) (control ?i)] 'utop-interrupt)
|
|
(define-key utop-mode-map [(control ?c) (control ?k)] 'utop-kill)
|
|
|
|
;; 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)
|