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

refactor utop-set-state, utop-cannot-edit, utop-process-line 

Make them all use pcase and and gets rid of some duplicate code in the process
This commit is contained in:
Rudi Grinberg 2017-08-15 12:56:11 -04:00
parent e838896e53
commit afca031099
1 changed files with 127 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

266
src/top/utop.el
View File

@ -358,34 +358,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) "]"))) (else ": 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"
@ -450,17 +441,14 @@ it is started."
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
(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
@ -587,106 +575,106 @@ 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)
;; Delete current input ;; Delete current input
(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"