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

84
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)
": copying")
((eq state 'done)
(let ((status (process-status utop-process)) (code (process-exit-status utop-process)))
(cond (cond
((and (eq status 'exit) (= code 0)) ((and (eq status 'exit) (= code 0))
": exited[0]") ": exited[0]")
((eq status 'exit) ((or (eq status 'exit) (eq status 'signal))
(let ((msg (concat ": exited[" (int-to-string code) "]"))) (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) (add-text-properties 0 (length msg) '(face bold) msg)
msg)) msg))
((eq status 'signal) (else ": unknown"))))
(let ((msg (concat ": killed[" (int-to-string code) "]"))) (_ ": unknown"))))
(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,18 +575,18 @@ 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)
@ -612,7 +600,7 @@ it is started."
(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")
@ -633,7 +621,7 @@ it is started."
(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
@ -642,14 +630,14 @@ it is started."
;; 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)
@ -663,23 +651,23 @@ it is started."
;; 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