haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #216 from rgrinberg/dev 

Emacs mode renovation
This commit is contained in:
Rudi Grinberg 2018-02-26 22:29:27 +07:00 committed by GitHub
parent 262539ae26 fe8b2b8aae
commit 730a8aeac1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 148 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

178
src/top/utop.el
View File

@ -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)
;; tabulated-list is a part of Emacs 24
(require 'tabulated-list nil t)
(require 'pcase)
(require 'tabulated-list)
;; +-----------------------------------------------------------------+
;; | 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
((eq major-mode 'tuareg-mode ) (nth 0 choices))
((eq major-mode 'typerex-mode ) (nth 1 choices))
((eq major-mode 'caml-mode ) (nth 2 choices))
((eq major-mode 'reason-mode ) (nth 3 choices))
(t (error (format "utop doesn't support the major mode \"%s\". It
supports caml, tuareg and typerex modes by default. For other
(nth
(pcase major-mode
('tuareg-mode 0)
('typerex-mode 1)
('caml-mode 2)
('reason-mode 3)
(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'
"
(symbol-name major-mode))))))
" 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
((eq state 'edit)
": idle")
((eq state 'comp)
": completion")
((eq state 'hist)
": history")
((eq state 'wait)
": running")
((eq state 'copy)
": copying")
((eq state 'done)
(let ((status (process-status utop-process)) (code (process-exit-status utop-process)))
(pcase state
('edit ": idle")
('comp ": completion")
('hist ": history")
('wait ": running")
('copy ": copying")
('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)
(let ((msg (concat ": exited[" (int-to-string code) "]")))
((or (eq status 'exit) (eq status 'signal))
(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)
(let ((msg (concat ": killed[" (int-to-string code) "]")))
(add-text-properties 0 (length msg) '(face bold) msg)
msg))
(t
": unknown"))))
(t
": unknown"))))
(t ": unknown"))))
(_ ": 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
; make sure without implementing another state that the type
; information has been already printed?
;; Currently not working - the communication is asynchronous so how to
;; make sure without implementing another state that the type
;; 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-last-type)
)
(utop-eval-string (utop-ident-at-point)))
;; (utop-last-type)
;; +-----------------------------------------------------------------+
;; | 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")))
((eq utop-state 'copy)
(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")))))
(signal
'text-read-only
(pcase utop-state
('wait "You cannot edit the buffer while ocaml is evaluating a phrase")
('done "You cannot edit the buffer when ocaml is not running")
('comp "You cannot edit the buffer while waiting for completion")
('copy "You cannot edit the buffer while waiting for copy of last input")
('hist "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)