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/ _build/
.merlin .merlin
*.install *.install
*.elc

354
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> ;; Copyright: (c) 2011, Jeremie Dimino <jeremie@dimino.org>
;; Author: Jeremie Dimino <jeremie@dimino.org> ;; Author: Jeremie Dimino <jeremie@dimino.org>
@ -18,16 +18,15 @@
;;; Code: ;;; Code:
(require 'easymenu) (require 'easymenu)
(require 'pcase)
;; tabulated-list is a part of Emacs 24 (require 'tabulated-list)
(require 'tabulated-list nil t)
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
;; | License | ;; | License |
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
(defconst utop-license "BSD3" (defconst utop-license "BSD3"
"Copyright (c) 2011, Jeremie Dimino <jeremie@dimino.org> "Copyright (c) 2011, Jeremie Dimino <jeremie@dimino.org>
All rights reserved. All rights reserved.
Redistribution and use in source and binary forms, with or without Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met: modification, are permitted provided that the following conditions are met:
@ -238,19 +237,20 @@ Caml toplevel")
(defun utop-compat-resolve (choices) (defun utop-compat-resolve (choices)
"Resolve a symbol based on the current major mode. CHOICES is a "Resolve a symbol based on the current major mode. CHOICES is a
list of 3 function symbols: (tuareg-symbol typerex-symbol caml-symbol)." 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: modes you need to set these variables:
- `utop-next-phrase-beginning' - `utop-next-phrase-beginning'
- `utop-discover-phrase' - `utop-discover-phrase'
" " major-mode))))
(symbol-name major-mode)))))) choices))
(defun utop-compat-next-phrase-beginning () (defun utop-compat-next-phrase-beginning ()
(funcall (funcall
@ -266,54 +266,6 @@ modes you need to set these variables:
caml-find-phrase caml-find-phrase
reason-discover-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 | ;; | Utils |
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
@ -356,34 +308,25 @@ it is started."
"Change the utop state and mode-line-process." "Change the utop state and mode-line-process."
(setq utop-state state) (setq utop-state state)
(setq mode-line-process (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) (cond
": copying") ((and (eq status 'exit) (= code 0))
((eq state 'done) ": exited[0]")
(let ((status (process-status utop-process)) (code (process-exit-status utop-process))) ((or (eq status 'exit) (eq status 'signal))
(cond (let* ((status-name (pcase status ('exit "exited") ('signal "killed")))
((and (eq status 'exit) (= code 0)) (msg (concat ": " status-name "[" (int-to-string code) "]")))
": exited[0]") (add-text-properties 0 (length msg) '(face bold) msg)
((eq status 'exit) msg))
(let ((msg (concat ": exited[" (int-to-string code) "]"))) (t ": unknown"))))
(add-text-properties 0 (length msg) '(face bold) msg) (_ ": unknown"))))
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"))))
(defun utop-send-data (cmd) (defun utop-send-data (cmd)
"Send current input to utop" "Send current input to utop"
@ -426,7 +369,7 @@ it is started."
(left-word 1) (left-word 1)
(setq iterating (not (save-excursion (setq iterating (not (save-excursion
(search-forward-regexp "[ \t\r\n].*" start-pos t))))))) (search-forward-regexp "[ \t\r\n].*" start-pos t)))))))
end-pos))) end-pos)))
(defun utop-ident-at-point () (defun utop-ident-at-point ()
"Identifier at point" "Identifier at point"
@ -434,33 +377,30 @@ it is started."
(end-pos (utop-ident-looking nil))) (end-pos (utop-ident-looking nil)))
(buffer-substring-no-properties start-pos end-pos))) (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 () (defun utop-type-at-point ()
"Find type of an identifier at point from uTop" "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 | ;; | Edition control |
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
(defun utop-cannot-edit () (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 (unless utop-inhibit-check
(cond (cond
((not (eq utop-state 'edit)) ((not (eq utop-state 'edit))
@ -585,72 +525,72 @@ it is started."
;; Extract the command and its argument ;; Extract the command and its argument
(string-match "\\`\\([a-z-]*\\):\\(.*\\)\\'" line) (string-match "\\`\\([a-z-]*\\):\\(.*\\)\\'" line)
(let ((command (match-string 1 line)) (argument (match-string 2 line))) (let ((command (match-string 1 line)) (argument (match-string 2 line)))
(cond (pcase command
;; Output on stdout ;; Output on stdout
((string= command "stdout") ("stdout"
(utop-insert-output argument 'utop-stdout)) (utop-insert-output argument 'utop-stdout))
;; Output on stderr ;; Output on stderr
((string= command "stderr") ("stderr"
(utop-insert-output argument 'utop-stderr)) (utop-insert-output argument 'utop-stderr))
;; Synchronisation of the phrase terminator ;; Synchronisation of the phrase terminator
((string= command "phrase-terminator") ("phrase-terminator"
(setq utop-phrase-terminator argument)) (setq utop-phrase-terminator argument))
;; A new prompt ;; A new prompt
((string= command "prompt") ("prompt"
(let ((prompt (apply utop-prompt ()))) (let ((prompt (apply utop-prompt ())))
;; Insert the new prompt ;; Insert the new prompt
(utop-insert-prompt prompt) (utop-insert-prompt prompt)
;; Increment the command number ;; Increment the command number
(setq utop-command-number (+ utop-command-number 1)) (setq utop-command-number (+ utop-command-number 1))
;; Send the initial command if any ;; Send the initial command if any
(when utop-initial-command (when utop-initial-command
(goto-char (point-max)) (goto-char (point-max))
(insert utop-initial-command) (insert utop-initial-command)
(setq utop-initial-command nil) (setq utop-initial-command nil)
(utop-eval-input nil t nil utop-initial-mode) (utop-eval-input nil t nil utop-initial-mode)
(setq utop-initial-mode nil)))) (setq utop-initial-mode nil))))
;; Input has been accepted ;; Input has been accepted
((string= command "accept") ("accept"
;; Add a newline character at the end of the buffer ;; Add a newline character at the end of the buffer
(goto-char (point-max)) (goto-char (point-max))
(insert "\n") (insert "\n")
;; Make input frozen ;; Make input frozen
(add-text-properties utop-prompt-max (point-max) '(face utop-frozen)) (add-text-properties utop-prompt-max (point-max) '(face utop-frozen))
;; Highlight errors ;; Highlight errors
(let ((offsets (split-string argument "," t))) (let ((offsets (split-string argument "," t)))
(while offsets (while offsets
(let ((a (string-to-number (car offsets))) (let ((a (string-to-number (car offsets)))
(b (string-to-number (cadr offsets)))) (b (string-to-number (cadr offsets))))
(add-text-properties (min (point-max) (+ utop-input-prompt-max a)) (add-text-properties (min (point-max) (+ utop-input-prompt-max a))
(min (point-max) (+ utop-input-prompt-max b)) (min (point-max) (+ utop-input-prompt-max b))
'(face utop-error)) '(face utop-error))
(setq offsets (cdr (cdr offsets)))))) (setq offsets (cdr (cdr offsets))))))
;; Make everything read-only ;; Make everything read-only
(add-text-properties (point-min) (point-max) utop-non-editable-properties) (add-text-properties (point-min) (point-max) utop-non-editable-properties)
;; Advance the prompt ;; Advance the prompt
(setq utop-prompt-min (point-max)) (setq utop-prompt-min (point-max))
(setq utop-prompt-max (point-max))) (setq utop-prompt-max (point-max)))
;; Continue editiong ;; Continue editiong
((string= command "continue") ("continue"
;; Add a newline character at the position where the user ;; Add a newline character at the position where the user
;; pressed enter ;; pressed enter
(when utop-pending-position (when utop-pending-position
(goto-char (+ utop-prompt-max utop-pending-position)) (goto-char (+ utop-prompt-max utop-pending-position))
(insert "\n")) (insert "\n"))
;; Reset the state ;; Reset the state
(utop-set-state 'edit)) (utop-set-state 'edit))
;; Part of a history entry ;; Part of a history entry
((string= command "history-data") ("history-data"
(cond (cond
(utop-pending-entry (utop-pending-entry
(setq utop-pending-entry (concat utop-pending-entry "\n" argument))) (setq utop-pending-entry (concat utop-pending-entry "\n" argument)))
(t (t
(setq utop-pending-entry argument)))) (setq utop-pending-entry argument))))
;; End of history data ;; End of history data
((string= command "history-end") ("history-end"
(progn (progn
(cond (cond
((eq utop-state 'copy) ((eq utop-state 'copy)
(kill-new utop-pending-entry)) (kill-new utop-pending-entry))
(t (t
(goto-char utop-prompt-max) (goto-char utop-prompt-max)
@ -658,35 +598,35 @@ it is started."
(delete-region utop-prompt-max (point-max)) (delete-region utop-prompt-max (point-max))
;; Insert entry ;; Insert entry
(insert utop-pending-entry))) (insert utop-pending-entry)))
;; Resume edition ;; Resume edition
(utop-set-state 'edit))) (utop-set-state 'edit)))
;; We are at a bound of history ;; We are at a bound of history
((string= command "history-bound") ("history-bound"
;; Just resume edition ;; Just resume edition
(utop-set-state 'edit)) (utop-set-state 'edit))
;; Complete with a word ;; Complete with a word
((string= command "completion-word") ("completion-word"
(utop-set-state 'edit) (utop-set-state 'edit)
(with-current-buffer utop-complete-buffer (insert argument)) (with-current-buffer utop-complete-buffer (insert argument))
;; Hide completion ;; Hide completion
(minibuffer-hide-completions)) (minibuffer-hide-completions))
;; Start of completion ;; Start of completion
((string= command "completion-start") ("completion-start"
(setq utop-completion nil)) (setq utop-completion nil))
;; A new possible completion ;; A new possible completion
((string= command "completion") ("completion"
(push argument utop-completion)) (push argument utop-completion))
;; End of completion ;; End of completion
((string= command "completion-stop") ("completion-stop"
(utop-set-state 'edit) (utop-set-state 'edit)
(if (> (length utop-completion) 1) (if (> (length utop-completion) 1)
(with-current-buffer utop-complete-buffer (with-current-buffer utop-complete-buffer
(with-output-to-temp-buffer "*Completions*" (with-output-to-temp-buffer "*Completions*"
(display-completion-list (nreverse utop-completion)))) (display-completion-list (nreverse utop-completion))))
(minibuffer-hide-completions)) (minibuffer-hide-completions))
(setq utop-completion nil))))) (setq utop-completion nil)))))
(defun utop-process-output (process output) (defun utop-process-output (_process output)
"Process the output of utop" "Process the output of utop"
(with-current-buffer utop-buffer-name (with-current-buffer utop-buffer-name
(utop-perform (utop-perform
@ -931,7 +871,7 @@ defaults to 0."
(unless (eq utop-state 'done) (unless (eq utop-state 'done)
(utop-send-string (format "exit:%d\n" (or exit-code 0)))))) (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." "Callback for process' state change."
(let ((buffer (get-buffer utop-buffer-name))) (let ((buffer (get-buffer utop-buffer-name)))
;; Do nothing if the buffer does not exist anymore ;; Do nothing if the buffer does not exist anymore
@ -988,7 +928,7 @@ defaults to 0."
;; Get the list of packages ;; Get the list of packages
(let* ((packages (utop-ocamlfind-list-packages)) (let* ((packages (utop-ocamlfind-list-packages))
(max-name-length 0)) (max-name-length 0))
;; Find the longest package name ;; Find the longest package name
(mapc (mapc
(lambda (package) (lambda (package)
(setq max-name-length (setq max-name-length
@ -1008,7 +948,7 @@ defaults to 0."
(setq packages (cdr packages)))) (setq packages (cdr packages))))
(setq tabulated-list-entries (nreverse tabulated-list-entries))) (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." "Print one findlib package entry."
(let ((width (cadr (elt tabulated-list-format 0)))) (let ((width (cadr (elt tabulated-list-format 0))))
(insert-text-button (elt cols 0) (insert-text-button (elt cols 0)
@ -1035,7 +975,7 @@ defaults to 0."
(utop-list-packages-mode) (utop-list-packages-mode)
(utop-list-packages--refresh) (utop-list-packages--refresh)
(tabulated-list-print t) (tabulated-list-print t)
(display-buffer buffer))) (display-buffer buffer)))
(defun utop-query-load-package-list () (defun utop-query-load-package-list ()
"Load packages defined in utop-package-list buffer local variable." "Load packages defined in utop-package-list buffer local variable."
@ -1235,7 +1175,7 @@ Special keys for utop:
(setq utop-command cmd) (setq utop-command cmd)
;; Put it in utop mode ;; Put it in utop mode
(with-current-buffer buf (utop-mode))))) (with-current-buffer buf (utop-mode)))))
buf)) buf))
(provide 'utop-minor-mode) (provide 'utop-minor-mode)
(provide 'utop) (provide 'utop)