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

allow to restart utop in the same buffer 

Ignore-this: 671e1170602f13fa2fb9a08a07abbbfd

darcs-hash:20120202220740-c41ad-4263d99bb641d6b1168a56eb98e8a978e5298685
This commit is contained in:
Jeremie Dimino 2012-02-02 23:07:40 +01:00
parent 465b5e8aad
commit 49e59693f9
1 changed files with 125 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

212
src/emacs/utop.el
View File

@ -118,6 +118,9 @@ before the end of prompt.")
- wait: ocaml is evaluating a phrase - wait: ocaml is evaluating a phrase
- done: ocaml has died.") - done: ocaml has died.")
(defvar utop-initial-command nil
"Initial phrase to evaluate.")
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
;; | Utils | ;; | Utils |
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
@ -152,11 +155,6 @@ before the end of prompt.")
((eq utop-state 'comp) ((eq utop-state 'comp)
(signal 'text-read-only '("You cannot edit the buffer while waiting for completion"))))) (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) (defun utop-before-change (start stop)
(unless utop-inhibit-check (unless utop-inhibit-check
(cond (cond
@ -214,38 +212,36 @@ before the end of prompt.")
(defun utop-insert-output (output &optional face) (defun utop-insert-output (output &optional face)
"Insert the given output before the prompt." "Insert the given output before the prompt."
(with-current-buffer utop-buffer-name (save-excursion
(save-excursion (let ((line (concat output "\n")))
(let ((line (concat output "\n"))) ;; Apply the given face if provided
;; Apply the given face if provided (when face (add-text-properties 0 (length line) (list 'face face) line))
(when face (add-text-properties 0 (length line) (list 'face face) line)) ;; Goto before the prompt
;; Goto before the prompt (goto-char utop-prompt-min)
(goto-char utop-prompt-min) ;; Insert the output
;; Insert the output (insert line)
(insert line) ;; Advance the prompt
;; Advance the prompt (setq utop-prompt-min (+ utop-prompt-min (length line)))
(setq utop-prompt-min (+ utop-prompt-min (length line))) (setq utop-prompt-max (+ utop-prompt-max (length line)))
(setq utop-prompt-max (+ utop-prompt-max (length line))) ;; Make everything before the end prompt read-only
;; Make everything before the end prompt read-only (add-text-properties (point-min) utop-prompt-max utop-non-editable-properties))))
(add-text-properties (point-min) utop-prompt-max utop-non-editable-properties)))))
(defun utop-insert-prompt (prompt) (defun utop-insert-prompt (prompt)
"Insert the given prompt." "Insert the given prompt."
(with-current-buffer utop-buffer-name ;; Goto the end of the buffer
;; Goto the end of the buffer (goto-char (point-max))
(goto-char (point-max)) ;; Make it the start of the prompt
;; Make it the start of the prompt (setq utop-prompt-min (point))
(setq utop-prompt-min (point)) ;; Insert the prompt
;; Insert the prompt (insert prompt)
(insert prompt) ;; Set the end of prompt
;; Set the end of prompt (setq utop-prompt-max (point))
(setq utop-prompt-max (point)) ;; Make everything before the end prompt read-only
;; Make everything before the end prompt read-only (add-text-properties (point-min) utop-prompt-max utop-non-editable-properties)
(add-text-properties (point-min) utop-prompt-max utop-non-editable-properties) ;; We are now editing
;; We are now editing (setq utop-state 'edit)
(setq utop-state 'edit) ;; Move the point to the end of buffer in all utop windows
;; Move the point to the end of buffer in all utop windows (utop-goto-point-max-all-windows))
(utop-goto-point-max-all-windows)))
(defun utop-process-line (line) (defun utop-process-line (line)
"Process one line from the utop sub-process." "Process one line from the utop sub-process."
@ -262,12 +258,10 @@ before the end of prompt.")
;; A new prompt ;; A new prompt
((string= command "prompt") ((string= command "prompt")
(let ((prompt (apply utop-prompt ()))) (let ((prompt (apply utop-prompt ())))
;; Check whether there is something to push to the history ;; Push pending input to the history if it is different from
(if (stringp utop-pending) ;; the top of the history
;; Push pending input to the history if it is different (when (and utop-pending (or (null utop-history) (not (string= utop-pending (car utop-history)))))
;; from the top of the history (push utop-pending utop-history))
(unless (and (consp utop-history) (string= utop-pending (car utop-history)))
(push utop-pending utop-history)))
;; Clear pending input ;; Clear pending input
(setq utop-pending nil) (setq utop-pending nil)
;; Reset history ;; Reset history
@ -278,7 +272,13 @@ before the end of 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
(when utop-initial-command
(goto-char (point-max))
(insert utop-initial-command ";;")
(setq utop-initial-command nil)
(utop-send-input))))
;; Continuation of previous input ;; Continuation of previous input
((string= command "continue") ((string= command "continue")
;; Reset history ;; Reset history
@ -336,7 +336,7 @@ sub-process."
(setq utop-state 'wait) (setq utop-state 'wait)
;; Push input to pending input ;; Push input to pending input
(let ((input (buffer-substring-no-properties utop-prompt-max (point-max)))) (let ((input (buffer-substring-no-properties utop-prompt-max (point-max))))
(if (stringp utop-pending) (if utop-pending
(setq utop-pending (concat utop-pending "\n" input)) (setq utop-pending (concat utop-pending "\n" input))
(setq utop-pending input)) (setq utop-pending input))
;; Goto the end of the buffer ;; Goto the end of the buffer
@ -356,7 +356,7 @@ sub-process."
;; Send all lines to utop ;; Send all lines to utop
(let ((lines (split-string input "\n"))) (let ((lines (split-string input "\n")))
(process-send-string utop-process "input:\n") (process-send-string utop-process "input:\n")
(while (consp lines) (while lines
;; Send the line ;; Send the line
(process-send-string utop-process (concat "data:" (car lines) "\n")) (process-send-string utop-process (concat "data:" (car lines) "\n"))
;; Remove it and continue ;; Remove it and continue
@ -380,7 +380,7 @@ sub-process."
(setq utop-state 'comp) (setq utop-state 'comp)
;; Send all lines to utop ;; Send all lines to utop
(process-send-string utop-process "complete:\n") (process-send-string utop-process "complete:\n")
(while (consp lines) (while lines
;; Send the line ;; Send the line
(process-send-string utop-process (concat "data:" (car lines) "\n")) (process-send-string utop-process (concat "data:" (car lines) "\n"))
;; Remove it and continue ;; Remove it and continue
@ -391,23 +391,28 @@ sub-process."
;; | Tuareg integration | ;; | Tuareg integration |
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
(defun utop-start () (defun utop-prepare-for-eval ()
"Start utop if not already started." "Prepare utop for evaluation."
;; Create the utop buffer if it does not exists, otherwise just (save-excursion
;; retreive it ;; Create the utop buffer if it does not exists, otherwise just
(let ((buf (get-buffer-create utop-buffer-name))) ;; retreive it
;; Make it appear (let ((buf (get-buffer-create utop-buffer-name)))
(display-buffer buf) ;; Make it appear
;; Set the utop mode in that buffer if not already done (display-buffer buf)
(with-current-buffer buf (unless (eq major-mode 'utop-mode) (utop-mode))))) (with-current-buffer buf
(cond
((not (eq major-mode 'utop-mode))
;; The buffer has just been created, start utop
(utop-mode))
((eq utop-state 'done)
;; UTop exited, restart it
(utop-restart))
((not (eq utop-state 'edit))
;; Edition cannot be performed right now
(utop-cannot-edit)))))))
(defun utop-eval-region (start end) (defun utop-eval (start end)
"Eval the current region in utop." "Eval the given 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 ;; From tuareg
(setq tuareg-interactive-last-phrase-pos-in-source start) (setq tuareg-interactive-last-phrase-pos-in-source start)
;; Select the text of the region ;; Select the text of the region
@ -422,32 +427,40 @@ sub-process."
(setq end (point)) (setq end (point))
(buffer-substring-no-properties start end)))) (buffer-substring-no-properties start end))))
(with-current-buffer utop-buffer-name (with-current-buffer utop-buffer-name
;; Insert it at the end of the utop buffer (cond
(goto-char (point-max)) ((eq utop-state 'edit)
(insert text ";;") ;; Insert it at the end of the utop buffer
;; Send input to utop now (goto-char (point-max))
(utop-send-input)))) (insert text ";;")
;; Send input to utop now
(utop-send-input))
((eq utop-state 'wait)
;; utop is starting, save the initial command to send
(setq utop-initial-command text))))))
(defun utop-eval-region (start end)
"Eval the current region in utop."
(interactive "r")
(utop-prepare-for-eval)
(utop-eval (start end)))
(defun utop-eval-phrase () (defun utop-eval-phrase ()
"Eval the surrounding Caml phrase (or block) in utop." "Eval the surrounding Caml phrase (or block) in utop."
(interactive) (interactive)
;; Start utop if needed (utop-prepare-for-eval)
(save-excursion (utop-start))
;; Check that we can send command now
(utop-check-edit)
;; Locate the near phrase and eval it
(let ((end)) (let ((end))
(save-excursion (save-excursion
(let ((pair (tuareg-discover-phrase))) (let ((pair (tuareg-discover-phrase)))
(setq end (nth 2 pair)) (setq end (nth 2 pair))
(utop-eval-region (nth 0 pair) (nth 1 pair)))) (utop-eval (nth 0 pair) (nth 1 pair))))
(if tuareg-skip-after-eval-phrase (if tuareg-skip-after-eval-phrase
(goto-char end)))) (goto-char end))))
(defun utop-eval-buffer () (defun utop-eval-buffer ()
"Send the buffer to utop." "Send the buffer to utop."
(interactive) (interactive)
(utop-eval-region (point-min) (point-max))) (utop-prepare-for-eval)
(utop-eval (point-min) (point-max)))
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
;; | Edition functions | ;; | Edition functions |
@ -505,6 +518,35 @@ sub-process."
;; | The mode | ;; | The mode |
;; +-----------------------------------------------------------------+ ;; +-----------------------------------------------------------------+
(defun utop-start ()
"Start utop."
;; Set the initial state: we are waiting for ocaml to send the
;; initial prompt
(setq utop-state 'wait)
;; Reset variables
(setq utop-prompt-min (point-max))
(setq utop-prompt-max (point-max))
(setq utop-output "")
(setq utop-command-number 0)
(setq utop-pending nil)
(setq utop-completion nil)
;; 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))
(defun utop-restart ()
"Restart utop."
(goto-char (point-max))
(utop-insert "\nRestarting...\n\n")
(utop-start))
(defun utop-mode () (defun utop-mode ()
"Caml Emacs-Lisp Toplevel. "Caml Emacs-Lisp Toplevel.
@ -524,6 +566,7 @@ sub-process."
(make-local-variable 'utop-pending) (make-local-variable 'utop-pending)
(make-local-variable 'utop-inhibit-check) (make-local-variable 'utop-inhibit-check)
(make-local-variable 'utop-state) (make-local-variable 'utop-state)
(make-local-variable 'utop-initial-command)
;; Set the major mode ;; Set the major mode
(setq major-mode 'utop-mode) (setq major-mode 'utop-mode)
@ -533,19 +576,6 @@ sub-process."
(setq utop-mode-map (make-sparse-keymap)) (setq utop-mode-map (make-sparse-keymap))
(use-local-map utop-mode-map) (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 ;; Set the hook to call before changing the buffer
(add-hook 'before-change-functions 'utop-before-change nil t) (add-hook 'before-change-functions 'utop-before-change nil t)
@ -565,6 +595,9 @@ sub-process."
;; Register the exit hook ;; Register the exit hook
(add-hook 'kill-buffer-hook (lambda () (run-hooks 'utop-exit-hook)) t t) (add-hook 'kill-buffer-hook (lambda () (run-hooks 'utop-exit-hook)) t t)
;; Start utop
(utop-start)
;; Call hooks ;; Call hooks
(run-mode-hooks 'utop-mode-hook)) (run-mode-hooks 'utop-mode-hook))
@ -581,8 +614,13 @@ sub-process."
(let ((buf (get-buffer-create utop-buffer-name))) (let ((buf (get-buffer-create utop-buffer-name)))
;; Jump to that buffer ;; Jump to that buffer
(pop-to-buffer buf) (pop-to-buffer buf)
;; Set the utop mode in that buffer if not already done (cond
(unless (eq major-mode 'utop-mode) (utop-mode)) ((not (eq major-mode 'utop-mode))
;; The buffer has just been created, set the utop mode
(utop-mode))
((eq utop-state 'done)
;; utop has exited, restart it
(utop-restart)))
;; Finally return it ;; Finally return it
buf)) buf))