slime-repl.el

;;; slime-repl.el --- 
;;
;; Original Author: Helmut Eller
;; Contributors: to many to mention
;; License: GNU GPL (same license as Emacs)
;;
;;; Description:
;;

;;
;;; Installation:
;;
;; Call slime-setup and include 'slime-repl as argument: 
;;
;;  (slime-setup '(slime-repl [others conribs ...]))
;;

(define-slime-contrib slime-repl
  "Read-Eval-Print Loop written in Emacs Lisp.

This contrib implements a Lisp Listener along with some niceties like
a persistent history and various \"shortcut\" commands.  Nothing here
depends on comint.el; I/O is multiplexed over SLIME's socket.

This used to be the default REPL for SLIME, but it was hard to
maintain."
  (:authors "too many to mention")
  (:license "GPL")
  (:on-load
   (add-hook 'slime-event-hooks 'slime-repl-event-hook-function)
   (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
   (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package)))

;;;;; slime-repl

(defgroup slime-repl nil
  "The Read-Eval-Print Loop (*slime-repl* buffer)."
  :prefix "slime-repl-"
  :group 'slime)

(defcustom slime-repl-shortcut-dispatch-char ?\,
  "Character used to distinguish repl commands from lisp forms."
  :type '(character)
  :group 'slime-repl)

(defcustom slime-repl-only-save-lisp-buffers t
  "When T we only attempt to save lisp-mode file buffers. When
  NIL slime will attempt to save all buffers (as per
  save-some-buffers). This applies to all ASDF related repl
  shortcuts."
  :type '(boolean)
  :group 'slime-repl)

(defface slime-repl-prompt-face
  (if (slime-face-inheritance-possible-p)
      '((t (:inherit font-lock-keyword-face)))
    '((((class color) (background light)) (:foreground "Purple"))
      (((class color) (background dark)) (:foreground "Cyan"))
      (t (:weight bold))))
  "Face for the prompt in the SLIME REPL."
  :group 'slime-repl)

(defface slime-repl-output-face
  (if (slime-face-inheritance-possible-p)
      '((t (:inherit font-lock-string-face)))
    '((((class color) (background light)) (:foreground "RosyBrown"))
      (((class color) (background dark)) (:foreground "LightSalmon"))
      (t (:slant italic))))
  "Face for Lisp output in the SLIME REPL."
  :group 'slime-repl)

(defface slime-repl-input-face
  '((t (:bold t)))
  "Face for previous input in the SLIME REPL."
  :group 'slime-repl)

(defface slime-repl-result-face
  '((t ()))
  "Face for the result of an evaluation in the SLIME REPL."
  :group 'slime-repl)

(defcustom slime-repl-history-file "~/.slime-history.eld"
  "File to save the persistent REPL history to."
  :type 'string
  :group 'slime-repl)

(defcustom slime-repl-history-size 200
  "*Maximum number of lines for persistent REPL history."
  :type 'integer
  :group 'slime-repl)

(defcustom slime-repl-history-file-coding-system 
  (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix)
        (t slime-net-coding-system))
  "*The coding system for the history file."
  :type 'symbol
  :group 'slime-repl)


;; dummy defvar for compiler
(defvar slime-repl-read-mode)

(defun slime-reading-p ()
  "True if Lisp is currently reading input from the REPL."
  (with-current-buffer (slime-output-buffer)
    slime-repl-read-mode))


;;;; Stream output

(slime-def-connection-var slime-connection-output-buffer nil
  "The buffer for the REPL.  May be nil or a dead buffer.")

(make-variable-buffer-local
 (defvar slime-output-start nil
   "Marker for the start of the output for the evaluation."))

(make-variable-buffer-local
 (defvar slime-output-end nil
   "Marker for end of output. New output is inserted at this mark."))

;; dummy definitions for the compiler
(defvar slime-repl-package-stack)
(defvar slime-repl-directory-stack)
(defvar slime-repl-input-start-mark)
(defvar slime-repl-prompt-start-mark)

(defun slime-output-buffer (&optional noprompt)
  "Return the output buffer, create it if necessary."
  (let ((buffer (slime-connection-output-buffer)))
    (or (if (buffer-live-p buffer) buffer)
        (setf (slime-connection-output-buffer)
              (let ((connection (slime-connection)))
                (with-current-buffer (slime-repl-buffer t connection)
                  (unless (eq major-mode 'slime-repl-mode) 
                    (slime-repl-mode))
                  (setq slime-buffer-connection connection)
		  (setq slime-buffer-package (slime-lisp-package connection))
                  (slime-reset-repl-markers)
                  (unless noprompt 
                    (slime-repl-insert-prompt))
                  (current-buffer)))))))

(defvar slime-repl-banner-function 'slime-repl-insert-banner)

(defun slime-repl-update-banner ()
  (funcall slime-repl-banner-function)
  (slime-move-point (point-max))
  (slime-mark-output-start)
  (slime-mark-input-start)
  (slime-repl-insert-prompt))

(defun slime-repl-insert-banner ()
  (when (zerop (buffer-size))
    (let ((welcome (concat "; SLIME " (or (slime-changelog-date)
                                          "- ChangeLog file not found"))))
      (insert welcome))))

(defun slime-init-output-buffer (connection)
  (with-current-buffer (slime-output-buffer t)
    (setq slime-buffer-connection connection
          slime-repl-directory-stack '()
          slime-repl-package-stack '())
    (slime-repl-update-banner)))

(defun slime-display-output-buffer ()
  "Display the output buffer and scroll to bottom."
  (with-current-buffer (slime-output-buffer)
    (goto-char (point-max))
    (unless (get-buffer-window (current-buffer) t)
      (display-buffer (current-buffer) t))
    (slime-repl-show-maximum-output)))

(defun slime-output-filter (process string)
  (with-current-buffer (process-buffer process)
    (when (and (plusp (length string))
               (eq (process-status slime-buffer-connection) 'open))
      (slime-write-string string))))

(defvar slime-open-stream-hooks)

(defun slime-open-stream-to-lisp (port)
  (let ((stream (open-network-stream "*lisp-output-stream*" 
                                     (slime-with-connection-buffer ()
                                       (current-buffer))
				     slime-lisp-host port)))
    (slime-set-query-on-exit-flag stream)
    (set-process-filter stream 'slime-output-filter)
    (let ((pcs (process-coding-system (slime-current-connection))))
      (set-process-coding-system stream (car pcs) (cdr pcs)))
    (when-let (secret (slime-secret))
      (slime-net-send secret stream))
    (run-hook-with-args 'slime-open-stream-hooks stream)
    stream))

(defun slime-io-speed-test (&optional profile)
  "A simple minded benchmark for stream performance.
If a prefix argument is given, instrument the slime package for
profiling before running the benchmark."
  (interactive "P")
  (eval-and-compile
    (require 'elp))
  (elp-reset-all)
  (elp-restore-all)
  (load "slime.el")
  ;;(byte-compile-file "slime-net.el" t)
  ;;(setq slime-log-events nil)
  (setq slime-enable-evaluate-in-emacs t)
  ;;(setq slime-repl-enable-presentations nil)
  (when profile
    (elp-instrument-package "slime-"))
  (kill-buffer (slime-output-buffer))
  (switch-to-buffer (slime-output-buffer))
  (delete-other-windows)
  (sit-for 0)
  (slime-repl-send-string "(swank:io-speed-test 4000 1)")
  (let ((proc (slime-inferior-process)))
    (when proc
      (display-buffer (process-buffer proc) t)
      (goto-char (point-max)))))

(defvar slime-write-string-function 'slime-repl-write-string)

(defun slime-write-string (string &optional target)
  "Insert STRING in the REPL buffer or some other TARGET.
If TARGET is nil, insert STRING as regular process
output.  If TARGET is :repl-result, insert STRING as the result of the
evaluation.  Other values of TARGET map to an Emacs marker via the 
hashtable `slime-output-target-to-marker'; output is inserted at this marker."
  (funcall slime-write-string-function string target))

(defun slime-repl-write-string (string &optional target)
  (case target
    ((nil) (slime-repl-emit string))
    (:repl-result (slime-repl-emit-result string))
    (t (slime-emit-to-target string target))))

(defvar slime-repl-popup-on-output nil
  "Display the output buffer when some output is written.
This is set to nil after displaying the buffer.")

(defmacro slime-save-marker (marker &rest body)
  (let ((pos (gensym "pos")))
  `(let ((,pos (marker-position ,marker)))
     (prog1 (progn . ,body)
       (set-marker ,marker ,pos)))))

(put 'slime-save-marker 'lisp-indent-function 1)

(defun slime-repl-emit (string)
  ;; insert the string STRING in the output buffer
  (with-current-buffer (slime-output-buffer)
    (save-excursion
      (goto-char slime-output-end)
      (slime-save-marker slime-output-start
        (slime-propertize-region '(face slime-repl-output-face 
                                        rear-nonsticky (face))
          (insert-before-markers string)
          (when (and (= (point) slime-repl-prompt-start-mark)
                     (not (bolp)))
            (insert-before-markers "\n")
            (set-marker slime-output-end (1- (point)))))))
    (when slime-repl-popup-on-output
      (setq slime-repl-popup-on-output nil)
      (display-buffer (current-buffer)))
    (slime-repl-show-maximum-output)))

(defun slime-repl-emit-result (string &optional bol)
  ;; insert STRING and mark it as evaluation result
  (with-current-buffer (slime-output-buffer)
    (save-excursion
      (slime-save-marker slime-output-start
        (slime-save-marker slime-output-end
          (goto-char slime-repl-input-start-mark)
          (when (and bol (not (bolp))) (insert-before-markers "\n"))
          (slime-propertize-region `(face slime-repl-result-face
                                          rear-nonsticky (face))
            (insert-before-markers string)))))
    (slime-repl-show-maximum-output)))

(defvar slime-last-output-target-id 0
  "The last integer we used as a TARGET id.")

(defvar slime-output-target-to-marker
  (make-hash-table)
  "Map from TARGET ids to Emacs markers.
The markers indicate where output should be inserted.")

(defun slime-output-target-marker (target)
  "Return the marker where output for TARGET should be inserted."
  (case target
    ((nil)
     (with-current-buffer (slime-output-buffer)
       slime-output-end))
    (:repl-result
     (with-current-buffer (slime-output-buffer)
       slime-repl-input-start-mark))
    (t
     (gethash target slime-output-target-to-marker))))

(defun slime-emit-to-target (string target)
  "Insert STRING at target TARGET.
See `slime-output-target-to-marker'."
  (let* ((marker (slime-output-target-marker target))
         (buffer (and marker (marker-buffer marker))))
    (when buffer
      (with-current-buffer buffer
        (save-excursion 
          ;; Insert STRING at MARKER, then move MARKER behind
          ;; the insertion.
          (goto-char marker)
          (insert-before-markers string)
          (set-marker marker (point)))))))

(defun slime-switch-to-output-buffer ()
  "Select the output buffer, when possible in an existing window.

Hint: You can use `display-buffer-reuse-frames' and
`special-display-buffer-names' to customize the frame in which
the buffer should appear."
  (interactive)
  (slime-pop-to-buffer (slime-output-buffer))
  (goto-char (point-max)))


;;;; REPL
;;
;; The REPL uses some markers to separate input from output.  The
;; usual configuration is as follows:
;; 
;;    ... output ...    ... result ...    prompt> ... input ...
;;    ^            ^                      ^       ^           ^
;;    output-start output-end  prompt-start       input-start point-max
;;
;; input-start is a right inserting marker, because
;; we want it to stay behind when the user inserts text.
;;
;; We maintain the following invariant:
;;
;;  output-start <= output-end <= input-start.
;;
;; This invariant is important, because we must be prepared for
;; asynchronous output and asynchronous reads.  ("Asynchronous" means,
;; triggered by Lisp and not by Emacs.)
;;
;; All output is inserted at the output-end marker.  Some care must be
;; taken when output-end and input-start are at the same position: if
;; we insert at that point, we must move the right markers.  We should
;; also not leave (window-)point in the middle of the new output.  The
;; idiom we use is a combination to slime-save-marker,
;; insert-before-markers, and manually updating window-point
;; afterwards.
;;
;; A "synchronous" evaluation request proceeds as follows: the user
;; inserts some text between input-start and point-max and then hits
;; return.  We send that region to Lisp, move the output and input
;; makers to the line after the input and wait.  When we receive the
;; result, we insert it together with a prompt between the output-end
;; and input-start mark.  See `slime-repl-insert-prompt'.
;;
;; It is possible that some output for such an evaluation request
;; arrives after the result.  This output is inserted before the
;; result (and before the prompt). 
;;
;; If we are in "reading" state, e.g., during a call to Y-OR-N-P,
;; there is no prompt between output-end and input-start.
;;

;; FIXME: slime-lisp-package should be local in a REPL buffer
(slime-def-connection-var slime-lisp-package
    "COMMON-LISP-USER"
  "The current package name of the Superior lisp.
This is automatically synchronized from Lisp.")

(slime-def-connection-var slime-lisp-package-prompt-string
    "CL-USER"
  "The current package name of the Superior lisp.
This is automatically synchronized from Lisp.")

(slime-make-variables-buffer-local
 (defvar slime-repl-package-stack nil
   "The stack of packages visited in this repl.")

 (defvar slime-repl-directory-stack nil
   "The stack of default directories associated with this repl.")

 (defvar slime-repl-prompt-start-mark)
 (defvar slime-repl-input-start-mark)
 (defvar slime-repl-old-input-counter 0
   "Counter used to generate unique `slime-repl-old-input' properties.
This property value must be unique to avoid having adjacent inputs be
joined together."))

(defun slime-reset-repl-markers ()
  (dolist (markname '(slime-output-start
                      slime-output-end
                      slime-repl-prompt-start-mark
                      slime-repl-input-start-mark))
    (set markname (make-marker))
    (set-marker (symbol-value markname) (point))))

;;;;; REPL mode setup

(defvar slime-repl-mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map lisp-mode-map)
    map))

(slime-define-keys slime-prefix-map
  ("\C-z" 'slime-switch-to-output-buffer)
  ("\M-p" 'slime-repl-set-package))

(slime-define-keys slime-mode-map 
  ("\C-c~" 'slime-sync-package-and-default-directory)
  ("\C-c\C-y" 'slime-call-defun))

(slime-define-keys slime-connection-list-mode-map
  ((kbd "RET") 'slime-goto-connection)
  ([return] 'slime-goto-connection))

(slime-define-keys slime-repl-mode-map
  ("\C-m" 'slime-repl-return)
  ([return] 'slime-repl-return)
  ("\C-j" 'slime-repl-newline-and-indent)
  ("\C-\M-m" 'slime-repl-closing-return)
  ([(control return)] 'slime-repl-closing-return)
  ("\C-a" 'slime-repl-bol)
  ([home] 'slime-repl-bol)
  ("\M-p" 'slime-repl-previous-input)
  ((kbd "C-<up>") 'slime-repl-backward-input)
  ("\M-n" 'slime-repl-next-input)
  ((kbd "C-<down>") 'slime-repl-forward-input)
  ("\M-r" 'slime-repl-previous-matching-input)
  ("\M-s" 'slime-repl-next-matching-input)
  ("\C-c\C-c" 'slime-interrupt)
  ;("\t"   'slime-complete-symbol)
  ("\t"   'slime-indent-and-complete-symbol)
  ("\M-\t" 'slime-complete-symbol)
  (" "    'slime-space)
  ("\C-c\C-o" 'slime-repl-clear-output)
  ("\C-c\M-o" 'slime-repl-clear-buffer)
  ("\C-c\C-u" 'slime-repl-kill-input)
  ("\C-c\C-n" 'slime-repl-next-prompt)
  ("\C-c\C-p" 'slime-repl-previous-prompt)
  ("\C-c\C-z" 'slime-nop))

(slime-define-keys slime-inspector-mode-map
  ((kbd "M-RET") 'slime-inspector-copy-down-to-repl))

(slime-define-keys sldb-mode-map
  ("\C-y" 'sldb-insert-frame-call-to-repl))

(def-slime-selector-method ?r
  "SLIME Read-Eval-Print-Loop."
  (slime-output-buffer))

(define-minor-mode slime-repl-map-mode
  "Minor mode which makes slime-repl-mode-map available.
\\{slime-repl-mode-map}"
  nil
  nil
  slime-repl-mode-map)

(defun slime-repl-mode () 
  "Major mode for interacting with a superior Lisp.
\\{slime-repl-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'slime-repl-mode)
  (slime-editing-mode 1)
  (slime-repl-map-mode 1)
  (lisp-mode-variables t)
  (set (make-local-variable 'lisp-indent-function)
       'common-lisp-indent-function)
  (setq font-lock-defaults nil)
  (setq mode-name "REPL")
  (setq slime-current-thread :repl-thread)
  (set (make-local-variable 'scroll-conservatively) 20)
  (set (make-local-variable 'scroll-margin) 0)
  (when slime-repl-history-file
    (slime-repl-safe-load-history)
    (slime-add-local-hook 'kill-buffer-hook 
                          'slime-repl-safe-save-merged-history))
  (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories)
  (slime-setup-command-hooks)
  ;; At the REPL, we define beginning-of-defun and end-of-defun to be
  ;; the start of the previous prompt or next prompt respectively.
  ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN.
  (set (make-local-variable 'beginning-of-defun-function) 
       'slime-repl-mode-beginning-of-defun)
  (set (make-local-variable 'end-of-defun-function) 
       'slime-repl-mode-end-of-defun)
  (slime-run-mode-hooks 'slime-repl-mode-hook))

(defun slime-repl-buffer (&optional create connection)
  "Get the REPL buffer for the current connection; optionally create."
  (funcall (if create #'get-buffer-create #'get-buffer)
           (format "*slime-repl %s*" (slime-connection-name connection))))

(defun slime-repl ()
  (interactive)
  (slime-switch-to-output-buffer))

(defun slime-repl-mode-beginning-of-defun ()
  (slime-repl-previous-prompt)
  t)

(defun slime-repl-mode-end-of-defun ()
  (slime-repl-next-prompt)
  t)

(defun slime-repl-send-string (string &optional command-string)
  (cond (slime-repl-read-mode
         (slime-repl-return-string string))
        (t (slime-repl-eval-string string))))

(defun slime-repl-eval-string (string)
  (slime-rex ()
      ((list 'swank:listener-eval string) (slime-lisp-package))
    ((:ok result)
     (slime-repl-insert-result result))
    ((:abort)
     (slime-repl-show-abort))))

(defun slime-repl-insert-result (result)
  (with-current-buffer (slime-output-buffer)
    (save-excursion
      (when result
        (destructure-case result
          ((:values &rest strings)
           (cond ((null strings)
                  (slime-repl-emit-result "; No value\n" t))
                 (t
                  (dolist (s strings)
                    (slime-repl-emit-result s t)))))))
      (slime-repl-insert-prompt))
    (slime-repl-show-maximum-output)))

(defun slime-repl-show-abort ()
  (with-current-buffer (slime-output-buffer)
    (save-excursion
      (slime-save-marker slime-output-start
        (slime-save-marker slime-output-end
          (goto-char slime-output-end)
          (insert-before-markers "; Evaluation aborted.\n")
          (slime-repl-insert-prompt))))
    (slime-repl-show-maximum-output)))

(defun slime-repl-insert-prompt ()
  "Insert the prompt (before markers!).
Set point after the prompt.  
Return the position of the prompt beginning."
  (goto-char slime-repl-input-start-mark)
  (slime-save-marker slime-output-start
    (slime-save-marker slime-output-end
      (unless (bolp) (insert-before-markers "\n"))
      (let ((prompt-start (point))
            (prompt (format "%s> " (slime-lisp-package-prompt-string))))
        (slime-propertize-region
            '(face slime-repl-prompt-face read-only t intangible t
                   slime-repl-prompt t
                   ;; emacs stuff
                   rear-nonsticky (slime-repl-prompt read-only face intangible)
                   ;; xemacs stuff
                   start-open t end-open t)
          (insert-before-markers prompt))
        (set-marker slime-repl-prompt-start-mark prompt-start)
        prompt-start))))

(defun slime-repl-show-maximum-output ()
  "Put the end of the buffer at the bottom of the window."
  (when (eobp)
    (let ((win (if (eq (window-buffer) (current-buffer))
                   (selected-window)
                   (get-buffer-window (current-buffer) t))))
      (when win
        (with-selected-window win
          (set-window-point win (point-max)) 
          (recenter -1))))))

(defvar slime-repl-current-input-hooks)

(defun slime-repl-current-input (&optional until-point-p)
  "Return the current input as string.
The input is the region from after the last prompt to the end of
buffer."
  (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks 
                                        until-point-p)
      (buffer-substring-no-properties slime-repl-input-start-mark 
                                      (if until-point-p 
                                          (point) 
                                        (point-max)))))

(defun slime-property-position (text-property &optional object)
  "Return the first position of TEXT-PROPERTY, or nil."
  (if (get-text-property 0 text-property object)
      0
    (next-single-property-change 0 text-property object)))
  
(defun slime-mark-input-start ()
  (set-marker slime-repl-input-start-mark (point) (current-buffer)))

(defun slime-mark-output-start ()
  (set-marker slime-output-start (point))
  (set-marker slime-output-end (point)))

(defun slime-mark-output-end ()
  ;; Don't put slime-repl-output-face again; it would remove the
  ;; special presentation face, for instance in the SBCL inspector.
  (add-text-properties slime-output-start slime-output-end
                       '(;;face slime-repl-output-face 
                         rear-nonsticky (face))))

(defun slime-repl-bol ()
  "Go to the beginning of line or the prompt."
  (interactive)
  (cond ((and (>= (point) slime-repl-input-start-mark)
              (slime-same-line-p (point) slime-repl-input-start-mark))
         (goto-char slime-repl-input-start-mark))
        (t (beginning-of-line 1)))
  (slime-preserve-zmacs-region))

(defun slime-preserve-zmacs-region ()
  "In XEmacs, ensure that the zmacs-region stays active after this command."
  (when (boundp 'zmacs-region-stays)
    (set 'zmacs-region-stays t)))

(defun slime-repl-in-input-area-p ()
   (<= slime-repl-input-start-mark (point)))

(defun slime-repl-at-prompt-start-p ()
  ;; This will not work on non-current prompts.
  (= (point) slime-repl-input-start-mark))

(defun slime-repl-beginning-of-defun ()
  "Move to beginning of defun."
  (interactive)
  ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt
  ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means
  ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to
  ;; jump to the start of the previous prompt.
  (if (and (not (slime-repl-at-prompt-start-p))
           (slime-repl-in-input-area-p))
      (goto-char slime-repl-input-start-mark)
    (beginning-of-defun))
  t)

;; FIXME: this looks very strange
(defun slime-repl-end-of-defun ()
  "Move to next of defun."
  (interactive)
  ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN.
  (if (and (not (= (point) (point-max))) 
           (slime-repl-in-input-area-p))
      (goto-char (point-max))
    (end-of-defun))
  t)

(defun slime-repl-previous-prompt ()
  "Move backward to the previous prompt."
  (interactive)
  (slime-repl-find-prompt t))

(defun slime-repl-next-prompt ()
  "Move forward to the next prompt."
  (interactive)
  (slime-repl-find-prompt))
 
(defun slime-repl-find-prompt (&optional backward)
  (let ((origin (point))
        (prop 'slime-repl-prompt))
    (while (progn 
             (slime-search-property-change prop backward)
             (not (or (slime-end-of-proprange-p prop) (bobp) (eobp)))))
    (unless (slime-end-of-proprange-p prop)
      (goto-char origin))))

(defun slime-search-property-change (prop &optional backward)
  (cond (backward 
         (goto-char (previous-single-char-property-change (point) prop)))
        (t 
         (goto-char (next-single-char-property-change (point) prop)))))

(defun slime-end-of-proprange-p (property)
  (and (get-char-property (max 1 (1- (point))) property)
       (not (get-char-property (point) property))))

(defvar slime-repl-return-hooks)

(defun slime-repl-return (&optional end-of-input)
  "Evaluate the current input string, or insert a newline.  
Send the current input only if a whole expression has been entered,
i.e. the parenthesis are matched. 

With prefix argument send the input even if the parenthesis are not
balanced."
  (interactive "P")
  (slime-check-connected)
  (cond (end-of-input
         (slime-repl-send-input))
        (slime-repl-read-mode ; bad style?
         (slime-repl-send-input t))
        ((and (get-text-property (point) 'slime-repl-old-input)
              (< (point) slime-repl-input-start-mark))
         (slime-repl-grab-old-input end-of-input)
         (slime-repl-recenter-if-needed))
        ((run-hook-with-args-until-success 'slime-repl-return-hooks))
        ((slime-input-complete-p slime-repl-input-start-mark (point-max))
         (slime-repl-send-input t))
        (t 
         (slime-repl-newline-and-indent)
         (message "[input not complete]"))))

(defun slime-repl-recenter-if-needed ()
  "Make sure that (point) is visible."
  (unless (pos-visible-in-window-p (point-max))
    (save-excursion
      (goto-char (point-max))
      (recenter -1))))

(defun slime-repl-send-input (&optional newline)
  "Goto to the end of the input and send the current input.
If NEWLINE is true then add a newline at the end of the input."
  (unless (slime-repl-in-input-area-p)
    (error "No input at point."))
  (goto-char (point-max))
  (let ((end (point))) ; end of input, without the newline
    (slime-repl-add-to-input-history 
     (buffer-substring slime-repl-input-start-mark end))
    (when newline 
      (insert "\n")
      (slime-repl-show-maximum-output))
    (let ((inhibit-modification-hooks t))
      (add-text-properties slime-repl-input-start-mark 
                           (point)
                           `(slime-repl-old-input
                             ,(incf slime-repl-old-input-counter))))
    (let ((overlay (make-overlay slime-repl-input-start-mark end)))
      ;; These properties are on an overlay so that they won't be taken
      ;; by kill/yank.
      (overlay-put overlay 'read-only t)
      (overlay-put overlay 'face 'slime-repl-input-face)))
  (let ((input (slime-repl-current-input)))
    (goto-char (point-max))
    (slime-mark-input-start)
    (slime-mark-output-start)
    (slime-repl-send-string input)))

(defun slime-repl-grab-old-input (replace)
  "Resend the old REPL input at point.  
If replace is non-nil the current input is replaced with the old
input; otherwise the new input is appended.  The old input has the
text property `slime-repl-old-input'."
  (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input)
    (let ((old-input (buffer-substring beg end)) ;;preserve
          ;;properties, they will be removed later
          (offset (- (point) beg)))
      ;; Append the old input or replace the current input
      (cond (replace (goto-char slime-repl-input-start-mark))
            (t (goto-char (point-max))
               (unless (eq (char-before) ?\ )
                 (insert " "))))
      (delete-region (point) (point-max))
      (save-excursion 
        (insert old-input)
        (when (equal (char-before) ?\n) 
          (delete-char -1)))
      (forward-char offset))))

(defun slime-repl-closing-return ()
  "Evaluate the current input string after closing all open lists."
  (interactive)
  (goto-char (point-max))
  (save-restriction
    (narrow-to-region slime-repl-input-start-mark (point))
    (while (ignore-errors (save-excursion (backward-up-list 1)) t)
      (insert ")")))
  (slime-repl-return))

(defun slime-repl-newline-and-indent ()
  "Insert a newline, then indent the next line.
Restrict the buffer from the prompt for indentation, to avoid being
confused by strange characters (like unmatched quotes) appearing
earlier in the buffer."
  (interactive)
  (save-restriction
    (narrow-to-region slime-repl-prompt-start-mark (point-max))
    (insert "\n")
    (lisp-indent-line)))

(defun slime-repl-delete-current-input ()
  "Delete all text from the prompt."
  (interactive)
  (delete-region slime-repl-input-start-mark (point-max)))

(defun slime-repl-kill-input ()
  "Kill all text from the prompt to point."
  (interactive)
  (cond ((< (marker-position slime-repl-input-start-mark) (point))
         (kill-region slime-repl-input-start-mark (point)))
        ((= (point) (marker-position slime-repl-input-start-mark))
         (slime-repl-delete-current-input))))

(defun slime-repl-replace-input (string)
  (slime-repl-delete-current-input)
  (insert-and-inherit string))

(defun slime-repl-input-line-beginning-position ()
  (save-excursion
    (goto-char slime-repl-input-start-mark)
    (line-beginning-position)))

(defvar slime-repl-clear-buffer-hook)

(defun slime-repl-clear-buffer ()
  "Delete the output generated by the Lisp process."
  (interactive)
  (let ((inhibit-read-only t))
    (delete-region (point-min) slime-repl-prompt-start-mark)
    (delete-region slime-output-start slime-output-end)
    (when (< (point) slime-repl-input-start-mark)
      (goto-char slime-repl-input-start-mark))
    (recenter t))
  (run-hooks 'slime-repl-clear-buffer-hook))

(defun slime-repl-clear-output ()
  "Delete the output inserted since the last input."
  (interactive)
  (let ((start (save-excursion 
                 (slime-repl-previous-prompt)
                 (ignore-errors (forward-sexp))
                 (forward-line)
                 (point)))
        (end (1- (slime-repl-input-line-beginning-position))))
    (when (< start end)
      (let ((inhibit-read-only t))
        (delete-region start end)
        (save-excursion
          (goto-char start)
          (insert ";;; output flushed"))))))

(defun slime-repl-set-package (package)
  "Set the package of the REPL buffer to PACKAGE."
  (interactive (list (let* ((p (slime-current-package))
                            (p (and p (slime-pretty-package-name p)))
                            (p (and (not (equal p (slime-lisp-package))) p)))
                       (slime-read-package-name "Package: " p))))
  (with-current-buffer (slime-output-buffer)
    (let ((previouse-point (- (point) slime-repl-input-start-mark)))
      (destructuring-bind (name prompt-string)
          (slime-repl-shortcut-eval `(swank:set-package ,package))
        (setf (slime-lisp-package) name)
        (setf (slime-lisp-package-prompt-string) prompt-string)
        (setf slime-buffer-package name)
        (slime-repl-insert-prompt)
        (when (plusp previouse-point)
          (goto-char (+ previouse-point slime-repl-input-start-mark)))))))


;;;;; History

(defcustom slime-repl-wrap-history nil
  "*T to wrap history around when the end is reached."
  :type 'boolean
  :group 'slime-repl)

(defcustom slime-repl-history-remove-duplicates nil
  "*When T all duplicates are removed except the last one."
  :type 'boolean
  :group 'slime-repl)

(defcustom slime-repl-history-trim-whitespaces nil
  "*When T strip all whitespaces from the beginning and end."
  :type 'boolean
  :group 'slime-repl)

(make-variable-buffer-local
 (defvar slime-repl-input-history '()
   "History list of strings read from the REPL buffer."))

(defun slime-string-trim (character-bag string)
  (flet ((find-bound (&optional from-end)
           (position-if-not (lambda (char) (memq char character-bag))
                            string :from-end from-end)))
    (let ((start (find-bound))
          (end (find-bound t)))
      (if start
          (subseq string start (1+ end))
          ""))))

(defun slime-repl-add-to-input-history (string)
  "Add STRING to the input history.
Empty strings and duplicates are ignored."
  (when slime-repl-history-trim-whitespaces
    (setq string (slime-string-trim '(?\n ?\ ?\t) string)))
  (unless (equal string "")
    (when slime-repl-history-remove-duplicates
      (setq slime-repl-input-history
            (remove string slime-repl-input-history)))
    (unless (equal string (car slime-repl-input-history))
      (push string slime-repl-input-history))))

;; These two vars contain the state of the last history search.  We
;; only use them if `last-command' was 'slime-repl-history-replace,
;; otherwise we reinitialize them.

(defvar slime-repl-input-history-position -1
  "Newer items have smaller indices.")

(defvar slime-repl-history-pattern nil
  "The regexp most recently used for finding input history.")

(defun slime-repl-history-replace (direction &optional regexp)
  "Replace the current input with the next line in DIRECTION.
DIRECTION is 'forward' or 'backward' (in the history list).
If REGEXP is non-nil, only lines matching REGEXP are considered."
  (setq slime-repl-history-pattern regexp)
  (let* ((min-pos -1)
         (max-pos (length slime-repl-input-history))
         (pos0 (cond ((slime-repl-history-search-in-progress-p)
                      slime-repl-input-history-position)
                     (t min-pos)))
         (pos (slime-repl-position-in-history pos0 direction (or regexp "")
                                              (slime-repl-current-input)))
         (msg nil))
    (cond ((and (< min-pos pos) (< pos max-pos))
           (slime-repl-replace-input (nth pos slime-repl-input-history))
           (setq msg (format "History item: %d" pos)))
          ((not slime-repl-wrap-history)
           (setq msg (cond ((= pos min-pos) "End of history")
                           ((= pos max-pos) "Beginning of history"))))
          (slime-repl-wrap-history
           (setq pos (if (= pos min-pos) max-pos min-pos))
           (setq msg "Wrapped history")))
    (when (or (<= pos min-pos) (<= max-pos pos))
      (when regexp
        (setq msg (concat msg "; no matching item"))))
    ;;(message "%s [%d %d %s]" msg start-pos pos regexp)
    (message "%s%s" msg (cond ((not regexp) "")
                              (t (format "; current regexp: %s" regexp))))
    (setq slime-repl-input-history-position pos)
    (setq this-command 'slime-repl-history-replace)))

(defun slime-repl-history-search-in-progress-p ()
  (eq last-command 'slime-repl-history-replace))

(defun slime-repl-terminate-history-search ()
  (setq last-command this-command))

(defun slime-repl-position-in-history (start-pos direction regexp
                                       &optional exclude-string)
  "Return the position of the history item matching REGEXP.
Return -1 resp. the length of the history if no item matches.
If EXCLUDE-STRING is specified then it's excluded from the search."
  ;; Loop through the history list looking for a matching line
  (let* ((step (ecase direction
                 (forward -1)
                 (backward 1)))
         (history slime-repl-input-history)
         (len (length history)))
    (loop for pos = (+ start-pos step) then (+ pos step)
          if (< pos 0) return -1
          if (<= len pos) return len
          for history-item = (nth pos history)
          if (and (string-match regexp history-item)
                  (not (equal history-item exclude-string)))
          return pos)))

(defun slime-repl-previous-input ()
  "Cycle backwards through input history.
If the `last-command' was a history navigation command use the
same search pattern for this command.
Otherwise use the current input as search pattern."
  (interactive)
  (slime-repl-history-replace 'backward (slime-repl-history-pattern t)))

(defun slime-repl-next-input ()
  "Cycle forwards through input history.
See `slime-repl-previous-input'."
  (interactive)
  (slime-repl-history-replace 'forward (slime-repl-history-pattern t)))

(defun slime-repl-forward-input ()
  "Cycle forwards through input history."
  (interactive)
  (slime-repl-history-replace 'forward (slime-repl-history-pattern)))

(defun slime-repl-backward-input ()
  "Cycle backwards through input history."
  (interactive)
  (slime-repl-history-replace 'backward (slime-repl-history-pattern)))

(defun slime-repl-previous-matching-input (regexp)
  (interactive (list (slime-read-from-minibuffer
		      "Previous element matching (regexp): ")))
  (slime-repl-terminate-history-search)
  (slime-repl-history-replace 'backward regexp))

(defun slime-repl-next-matching-input (regexp)
  (interactive (list (slime-read-from-minibuffer
		      "Next element matching (regexp): ")))
  (slime-repl-terminate-history-search)
  (slime-repl-history-replace 'forward regexp))

(defun slime-repl-history-pattern (&optional use-current-input)
  "Return the regexp for the navigation commands."
  (cond ((slime-repl-history-search-in-progress-p)
         slime-repl-history-pattern)
        (use-current-input
         (assert (<= slime-repl-input-start-mark (point)))
         (let ((str (slime-repl-current-input t)))
           (cond ((string-match "^[ \n]*$" str) nil)
                 (t (concat "^" (regexp-quote str))))))
        (t nil)))

(defun slime-repl-delete-from-input-history (string)
  "Delete STRING from the repl input history. 

When string is not provided then clear the current repl input and
use it as an input.  This is useful to get rid of unwanted repl
history entries while navigating the repl history."
  (interactive (list (slime-repl-current-input)))
  (let ((merged-history 
         (slime-repl-merge-histories slime-repl-input-history
                                     (slime-repl-read-history nil t))))
    (setq slime-repl-input-history
          (delete* string merged-history :test #'string=))
    (slime-repl-save-history))
  (slime-repl-delete-current-input))

;;;;; Persistent History 

(defun slime-repl-merge-histories (old-hist new-hist)
  "Merge entries from OLD-HIST and NEW-HIST."
  ;; Newer items in each list are at the beginning.
  (let* ((ht (make-hash-table :test #'equal))
         (test (lambda (entry)
                 (or (gethash entry ht)
                     (progn (setf (gethash entry ht) t)
                            nil)))))
    (append (remove-if test new-hist)
            (remove-if test old-hist))))

(defun slime-repl-load-history (&optional filename)
  "Set the current SLIME REPL history.
It can be read either from FILENAME or `slime-repl-history-file' or
from a user defined filename."
  (interactive (list (slime-repl-read-history-filename)))
  (let ((file (or filename slime-repl-history-file)))
    (setq slime-repl-input-history (slime-repl-read-history file t))))

(defun slime-repl-read-history (&optional filename noerrer)
  "Read and return the history from FILENAME.  
The default value for FILENAME is `slime-repl-history-file'.
If NOERROR is true return and the file doesn't exits return nil."
  (let ((file (or filename slime-repl-history-file)))
    (cond ((not (file-readable-p file)) '())
          (t (with-temp-buffer
               (insert-file-contents file)
               (read (current-buffer)))))))

(defun slime-repl-read-history-filename ()
  (read-file-name "Use SLIME REPL history from file: " 
                  slime-repl-history-file))

(defun slime-repl-save-merged-history (&optional filename)
  "Read the history file, merge the current REPL history and save it.
This tries to be smart in merging the history from the file and the
current history in that it tries to detect the unique entries using
`slime-repl-merge-histories'."
  (interactive (list (slime-repl-read-history-filename)))
  (let ((file (or filename slime-repl-history-file)))
    (with-temp-message "saving history..."
      (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t)
                                              slime-repl-input-history)))
        (slime-repl-save-history file hist)))))

(defun slime-repl-save-history (&optional filename history)
  "Simply save the current SLIME REPL history to a file.
When SLIME is setup to always load the old history and one uses only
one instance of slime all the time, there is no need to merge the
files and this function is sufficient.

When the list is longer than `slime-repl-history-size' it will be
truncated.  That part is untested, though!"
  (interactive (list (slime-repl-read-history-filename)))
  (let ((file (or filename slime-repl-history-file))
        (hist (or history slime-repl-input-history)))
    (unless (file-writable-p file)
      (error (format "History file not writable: %s" file)))
    (let ((hist (subseq hist 0 (min (length hist) slime-repl-history-size))))
      ;;(message "saving %s to %s\n" hist file)
      (with-temp-file file
        (let ((cs slime-repl-history-file-coding-system)
              (print-length nil) (print-level nil))
          (setq buffer-file-coding-system cs)
          (insert (format ";; -*- coding: %s -*-\n" cs))
          (insert ";; History for SLIME REPL. Automatically written.\n"
                  ";; Edit only if you know what you're doing\n")
          (prin1 (mapcar #'substring-no-properties hist) (current-buffer)))))))

(defun slime-repl-save-all-histories ()
  "Save the history in each repl buffer."
  (dolist (b (buffer-list))
    (with-current-buffer b
      (when (eq major-mode 'slime-repl-mode)
        (slime-repl-safe-save-merged-history)))))

(defun slime-repl-safe-save-merged-history ()
  (slime-repl-call-with-handler 
   #'slime-repl-save-merged-history
   "%S while saving the history. Continue? "))

(defun slime-repl-safe-load-history ()
  (slime-repl-call-with-handler 
   #'slime-repl-load-history
   "%S while loading the history. Continue? "))

(defun slime-repl-call-with-handler (fun query)
  "Call FUN in the context of an error handler.
The handler will use qeuery to ask the use if the error should be ingored."
  (condition-case err
      (funcall fun)
    (error 
     (if (y-or-n-p (format query (error-message-string err)))
         nil
       (signal (car err) (cdr err))))))


;;;;; REPL Read Mode

(define-key slime-repl-mode-map
  (string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut)

(define-minor-mode slime-repl-read-mode 
  "Mode the read input from Emacs
\\{slime-repl-read-mode-map}"
  nil
  "[read]"
  '(("\C-m" . slime-repl-return)
    ([return] . slime-repl-return)
    ("\C-c\C-b" . slime-repl-read-break)
    ("\C-c\C-c" . slime-repl-read-break)))

(make-variable-buffer-local
 (defvar slime-read-string-threads nil))

(make-variable-buffer-local
 (defvar slime-read-string-tags nil))

(defun slime-repl-read-string (thread tag)
  (slime-switch-to-output-buffer)
  (push thread slime-read-string-threads)
  (push tag slime-read-string-tags)
  (goto-char (point-max))
  (slime-mark-output-end)
  (slime-mark-input-start)
  (slime-repl-read-mode 1))

(defun slime-repl-return-string (string)
  (slime-dispatch-event `(:emacs-return-string 
                          ,(pop slime-read-string-threads)
                          ,(pop slime-read-string-tags)
                          ,string))
  (slime-repl-read-mode -1))

(defun slime-repl-read-break ()
  (interactive)
  (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads))))

(defun slime-repl-abort-read (thread tag)
  (with-current-buffer (slime-output-buffer)
    (pop slime-read-string-threads)
    (pop slime-read-string-tags)
    (slime-repl-read-mode -1)
    (message "Read aborted")))


;;;;; REPL handlers

(defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.))
  symbol names handler one-liner)

(defvar slime-repl-shortcut-table nil
  "A list of slime-repl-shortcuts")

(defvar slime-repl-shortcut-history '()
  "History list of shortcut command names.")

(defvar slime-within-repl-shortcut-handler-p nil
  "Bound to T if we're in a REPL shortcut handler invoked from the REPL.")

(defun slime-handle-repl-shortcut ()
  (interactive)
  (if (> (point) slime-repl-input-start-mark)
      (insert (string slime-repl-shortcut-dispatch-char))
      (let ((shortcut (slime-lookup-shortcut
                       (completing-read "Command: " 
                                        (slime-bogus-completion-alist
                                         (slime-list-all-repl-shortcuts))
                                        nil t nil
                                        'slime-repl-shortcut-history))))
        (with-struct (slime-repl-shortcut. handler) shortcut
          (let ((slime-within-repl-shortcut-handler-p t))
            (call-interactively handler))))))

(defun slime-list-all-repl-shortcuts ()
  (loop for shortcut in slime-repl-shortcut-table
        append (slime-repl-shortcut.names shortcut)))

(defun slime-lookup-shortcut (name)
  (find-if (lambda (s) (member name (slime-repl-shortcut.names s)))
           slime-repl-shortcut-table))

(defmacro defslime-repl-shortcut (elisp-name names &rest options)
  "Define a new repl shortcut. ELISP-NAME is a symbol specifying
the name of the interactive function to create, or NIL if no
function should be created. 

NAMES is a list of \(full-name . aliases\). 

OPTIONS is an plist specifying the handler doing the actual work
of the shortcut \(`:handler'\), and a help text \(`:one-liner'\)."
  `(progn
     ,(when elisp-name
        `(defun ,elisp-name ()
           (interactive)
           (call-interactively ,(second (assoc :handler options)))))
     (let ((new-shortcut (make-slime-repl-shortcut
                          :symbol ',elisp-name
                          :names (list ,@names)
                          ,@(apply #'append options))))
       (setq slime-repl-shortcut-table
             (remove-if (lambda (s)
                          (member ',(car names) (slime-repl-shortcut.names s)))
                        slime-repl-shortcut-table))
       (push new-shortcut slime-repl-shortcut-table)
       ',elisp-name)))

(defun slime-repl-shortcut-eval (sexp &optional package)
  "This function should be used by REPL shortcut handlers instead
of `slime-eval' to evaluate their final expansion. (This
expansion will be added to the REPL's history.)"
  (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo?
    (slime-repl-add-to-input-history (prin1-to-string sexp)))
  (slime-eval sexp package))

(defun slime-repl-shortcut-eval-async (sexp &optional cont package)
  "This function should be used by REPL shortcut handlers instead
of `slime-eval-async' to evaluate their final expansion. (This
expansion will be added to the REPL's history.)"
  (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo?
    (slime-repl-add-to-input-history (prin1-to-string sexp)))
  (slime-eval-async sexp cont package))

(defun slime-list-repl-short-cuts ()
  (interactive)
  (slime-with-popup-buffer ((slime-buffer-name :repl-help))
    (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string<
                        :key (lambda (x) 
                               (car (slime-repl-shortcut.names x))))))
      (save-excursion
        (dolist (shortcut table)
          (let ((names (slime-repl-shortcut.names shortcut)))
            (insert (pop names)) ;; first print the "full" name
            (when names
              ;; we also have aliases
              (insert " (aka ")
              (while (cdr names)
                (insert (pop names) ", "))
              (insert (car names) ")"))
            (when (slime-repl-shortcut.one-liner shortcut)
              (insert "\n     " (slime-repl-shortcut.one-liner shortcut)))
            (insert "\n")))))))

(defun slime-save-some-lisp-buffers ()
  (if slime-repl-only-save-lisp-buffers
      (save-some-buffers nil (lambda ()
                               (and (memq major-mode slime-lisp-modes)
                                    (not (null buffer-file-name)))))
      (save-some-buffers)))
  

(defslime-repl-shortcut slime-repl-shortcut-help ("help" "?")
  (:handler 'slime-list-repl-short-cuts)
  (:one-liner "Display the help."))

(defslime-repl-shortcut nil ("change-directory" "!d" "cd")
  (:handler 'slime-set-default-directory)
  (:one-liner "Change the current directory."))

(defslime-repl-shortcut nil ("pwd")
  (:handler (lambda () 
              (interactive)
              (let ((dir (slime-eval `(swank:default-directory))))
                (message "Directory %s" dir))))
  (:one-liner "Show the current directory."))

(defslime-repl-shortcut slime-repl-push-directory
    ("push-directory" "+d" "pushd")
  (:handler (lambda (directory)
              (interactive
               (list (read-directory-name
                      "Push directory: "
                      (slime-eval '(swank:default-directory))
                      nil nil "")))
              (push (slime-eval '(swank:default-directory))
                    slime-repl-directory-stack)
              (slime-set-default-directory directory)))
  (:one-liner "Save the current directory and set it to a new one."))

(defslime-repl-shortcut slime-repl-pop-directory
    ("pop-directory" "-d" "popd")
  (:handler (lambda ()
              (interactive)
              (if (null slime-repl-directory-stack)
                  (message "Directory stack is empty.")
                  (slime-set-default-directory
                   (pop slime-repl-directory-stack)))))
  (:one-liner "Restore the last saved directory."))

(defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in")
  (:handler 'slime-repl-set-package)
  (:one-liner "Change the current package."))

(defslime-repl-shortcut slime-repl-push-package ("push-package" "+p")
  (:handler (lambda (package)
              (interactive (list (slime-read-package-name "Package: ")))
              (push (slime-lisp-package) slime-repl-package-stack)
              (slime-repl-set-package package)))
  (:one-liner "Save the current package and set it to a new one."))

(defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p")
  (:handler (lambda ()
              (interactive)
              (if (null slime-repl-package-stack)
                  (message "Package stack is empty.")
                  (slime-repl-set-package
                   (pop slime-repl-package-stack)))))
  (:one-liner "Restore the last saved package."))

(defslime-repl-shortcut slime-repl-resend ("resend-form")
  (:handler (lambda ()
              (interactive)
              (insert (car slime-repl-input-history))
              (insert "\n")
              (slime-repl-send-input)))
  (:one-liner "Resend the last form."))

(defslime-repl-shortcut slime-repl-disconnect ("disconnect")
  (:handler 'slime-disconnect)
  (:one-liner "Disconnect the current connection."))

(defslime-repl-shortcut slime-repl-disconnect-all ("disconnect-all")
  (:handler 'slime-disconnect-all)
  (:one-liner "Disconnect all connections."))

(defslime-repl-shortcut slime-repl-sayoonara ("sayoonara")
  (:handler (lambda ()
              (interactive)
              (when (slime-connected-p)
                (slime-quit-lisp))
              (slime-kill-all-buffers)))
  (:one-liner "Quit all Lisps and close all SLIME buffers."))

(defslime-repl-shortcut slime-repl-quit ("quit")
  (:handler (lambda ()
	      (interactive)
              ;; `slime-quit-lisp' determines the connection to quit
              ;; on behalf of the REPL's `slime-buffer-connection'.
              (let ((repl-buffer (slime-output-buffer)))
                (slime-quit-lisp)
                (kill-buffer repl-buffer))))
  (:one-liner "Quit the current Lisp."))

(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!")
  (:handler (lambda (name value)
              (interactive (list (slime-read-symbol-name "Name (symbol): " t)
                                 (slime-read-from-minibuffer "Value: " "*")))
              (insert "(cl:defparameter " name " " value 
                      " \"REPL generated global variable.\")")
              (slime-repl-send-input t)))
  (:one-liner "Define a new global, special, variable."))

(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl")
  (:handler (lambda (filename)
              (interactive (list (expand-file-name
                                  (read-file-name "File: " nil nil nil nil))))
              (slime-save-some-lisp-buffers)
              (slime-repl-shortcut-eval-async
               `(swank:compile-file-if-needed 
                 ,(slime-to-lisp-filename filename) t)
               #'slime-compilation-finished)))
  (:one-liner "Compile (if neccessary) and load a lisp file."))

(defslime-repl-shortcut nil  ("restart-inferior-lisp")
  (:handler 'slime-restart-inferior-lisp)
  (:one-liner "Restart *inferior-lisp* and reconnect SLIME."))

(defun slime-redirect-inferior-output (&optional noerror)
  "Redirect output of the inferior-process to the REPL buffer."
  (interactive)
  (let ((proc (slime-inferior-process)))
    (cond (proc
           (let ((filter (slime-rcurry #'slime-inferior-output-filter 
                                       (slime-current-connection))))
             (set-process-filter proc filter)))
	  (noerror)
	  (t (error "No inferior lisp process")))))

(defun slime-inferior-output-filter (proc string conn)
  (cond ((eq (process-status conn) 'closed)
         (message "Connection closed.  Removing inferior output filter.")
         (message "Lost output: %S" string)
         (set-process-filter proc nil))
        (t
         (slime-output-filter conn string))))

(defun slime-redirect-trace-output ()
  "Redirect the trace output to a separate Emacs buffer."
  (interactive)
  (let ((buffer (get-buffer-create (slime-buffer-name :trace))))
    (with-current-buffer buffer
      (let ((marker (copy-marker (buffer-size)))
            (target (incf slime-last-output-target-id)))
        (puthash target marker slime-output-target-to-marker)
        (slime-eval `(swank:redirect-trace-output ,target))))
    ;; Note: We would like the entries in
    ;; slime-output-target-to-marker to disappear when the buffers are
    ;; killed.  We cannot just make the hash-table ":weakness 'value"
    ;; -- there is no reference from the buffers to the markers in the
    ;; buffer, so entries would disappear even though the buffers are
    ;; alive.  Best solution might be to make buffer-local variables
    ;; that keep the markers. --mkoeppe
    (pop-to-buffer buffer)))

(defun slime-call-defun ()
  "Insert a call to the toplevel form defined around point into the REPL."
  (interactive)
  (flet ((insert-call (symbol &key (function t)
                              defclass)
           (let* ((qualified-symbol-name (slime-qualify-cl-symbol-name symbol))
                  (symbol-name (slime-cl-symbol-name qualified-symbol-name))
                  (symbol-package (slime-cl-symbol-package qualified-symbol-name))
                  (call (if (equalp (slime-lisp-package) symbol-package)
                            symbol-name
                            qualified-symbol-name)))
             (slime-switch-to-output-buffer)
             (goto-char slime-repl-input-start-mark)
             (insert (if function
                         "("
                         " "))
             (if defclass
                 (insert "make-instance '"))
             (insert call)
             (when function
               (insert " ")
               (save-excursion (insert ")")))
             (unless function
               (goto-char slime-repl-input-start-mark)))))           
    (let ((toplevel (slime-parse-toplevel-form)))
      (if (symbolp toplevel)
          (error "Not in a function definition")
          (destructure-case toplevel
            (((:defun :defgeneric :defmacro :define-compiler-macro) symbol)
             (insert-call symbol))
            ((:defmethod symbol &rest args)
             (declare (ignore args))
             (insert-call symbol))
            (((:defparameter :defvar :defconstant) symbol)
             (insert-call symbol :function nil))
            (((:defclass) symbol)
             (insert-call symbol :defclass t))
            (t
             (error "Not in a function definition")))))))

(defun slime-inspector-copy-down-to-repl (number)
   "Evaluate the inspector slot at point via the REPL (to set `*')."
   (interactive (list (or (get-text-property (point) 'slime-part-number)
                          (error "No part at point"))))
   (slime-repl-send-string (format "%s" `(swank:inspector-nth-part ,number)))
   (slime-repl))

(defun sldb-insert-frame-call-to-repl ()
  "Insert a call to a frame at point."
  (interactive)
  (let ((call (slime-eval `(swank-backend::frame-call
                            ,(sldb-frame-number-at-point)))))
    (slime-switch-to-output-buffer)
    (if (>= (point) slime-repl-prompt-start-mark)
        (insert call)
	(save-excursion
	  (goto-char (point-max))
	  (insert call))))
  (slime-repl))

(defun slime-set-default-directory (directory)
  "Make DIRECTORY become Lisp's current directory."
  (interactive (list (read-directory-name "Directory: " nil nil t)))
  (let ((dir (expand-file-name directory)))
    (message "default-directory: %s"
             (slime-from-lisp-filename
              (slime-repl-shortcut-eval `(swank:set-default-directory
                                          ,(slime-to-lisp-filename dir)))))
    (with-current-buffer (slime-output-buffer)
      (setq default-directory dir))))

(defun slime-sync-package-and-default-directory ()
  "Set Lisp's package and directory to the values in current buffer."
  (interactive)
  (let* ((package (slime-current-package))
         (exists-p (or (null package)
                       (slime-eval `(cl:packagep (swank::guess-package ,package)))))
         (directory default-directory))
    (when (and package exists-p)
      (slime-repl-set-package package))
    (slime-set-default-directory directory)
    ;; Sync *inferior-lisp* dir
    (let* ((proc (slime-process))
           (buffer (and proc (process-buffer proc))))
      (when buffer
        (with-current-buffer buffer
          (setq default-directory directory))))
    (message "package: %s%s  directory: %s"
             (with-current-buffer (slime-output-buffer)
               (slime-lisp-package))
             (if exists-p "" (format " (package %s doesn't exist)" package))
             directory)))

(defun slime-goto-connection ()
  "Switch to the REPL buffer for the connection at point."
  (interactive)
  (let ((slime-dispatching-connection (slime-connection-at-point)))
    (switch-to-buffer (slime-output-buffer))))

(defun slime-repl-inside-string-or-comment-p ()
  (save-restriction
    (when (and (boundp 'slime-repl-input-start-mark)
               slime-repl-input-start-mark
               (>= (point) slime-repl-input-start-mark))
      (narrow-to-region slime-repl-input-start-mark (point)))
    (slime-inside-string-or-comment-p)))

(defvar slime-repl-easy-menu
  (let ((C '(slime-connected-p)))
    `("REPL"
      [ "Send Input"             slime-repl-return ,C ]
      [ "Close and Send Input "  slime-repl-closing-return ,C ]
      [ "Interrupt Lisp process" slime-interrupt ,C ]
      "--"
      [ "Previous Input"         slime-repl-previous-input t ]
      [ "Next Input"             slime-repl-next-input t ]
      [ "Goto Previous Prompt "  slime-repl-previous-prompt t ]
      [ "Goto Next Prompt "      slime-repl-next-prompt t ]
      [ "Clear Last Output"      slime-repl-clear-output t ]
      [ "Clear Buffer "          slime-repl-clear-buffer t ]
      [ "Kill Current Input"     slime-repl-kill-input t ])))

(defun slime-repl-add-easy-menu ()
  (easy-menu-define menubar-slime-repl slime-repl-mode-map
    "REPL" slime-repl-easy-menu)
  (easy-menu-define menubar-slime slime-repl-mode-map 
    "SLIME" slime-easy-menu)
  (easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map))

(add-hook 'slime-repl-mode-hook 'slime-repl-add-easy-menu)

(defun slime-hide-inferior-lisp-buffer ()
  "Display the REPL buffer instead of the *inferior-lisp* buffer."
  (let* ((buffer (if (slime-process) 
                     (process-buffer (slime-process))))
         (window (if buffer (get-buffer-window buffer t)))
         (repl-buffer (slime-output-buffer t))
         (repl-window (get-buffer-window repl-buffer)))
    (when buffer
      (bury-buffer buffer))
    (cond (repl-window
           (when window
             (delete-window window)))
          (window
           (set-window-buffer window repl-buffer))
          (t
           (pop-to-buffer repl-buffer)
           (goto-char (point-max))))))

(defun slime-repl-connected-hook-function ()
  (destructuring-bind (package prompt) 
      (let ((slime-current-thread t))
	(slime-eval '(swank:create-repl nil)))
    (setf (slime-lisp-package) package)
    (setf (slime-lisp-package-prompt-string) prompt))
  (slime-hide-inferior-lisp-buffer)
  (slime-init-output-buffer (slime-connection)))

(defun slime-repl-event-hook-function (event)
  (destructure-case event
    ((:write-string output &optional target)
     (slime-write-string output target)
     t)
    ((:read-string thread tag)
     (assert thread)
     (slime-repl-read-string thread tag)
     t)
    ((:read-aborted thread tag)
     (slime-repl-abort-read thread tag)
     t)
    ((:open-dedicated-output-stream port)
     (slime-open-stream-to-lisp port)
     t)
    ((:new-package package prompt-string)
     (setf (slime-lisp-package) package)
     (setf (slime-lisp-package-prompt-string) prompt-string)
     (let ((buffer (slime-connection-output-buffer)))
       (when (buffer-live-p buffer)
	 (with-current-buffer buffer
	   (setq slime-buffer-package package))))
     t)
    (t nil)))

(defun slime-repl-find-buffer-package ()
  (or (slime-search-buffer-package)
      (slime-lisp-package)))

(defun slime-repl-remove-hooks ()
  (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function)
  (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function))

(let ((byte-compile-warnings '()))
  (mapc #'byte-compile
	'(slime-repl-event-hook-function
	  slime-write-string
	  slime-repl-write-string
	  slime-repl-emit
	  slime-repl-show-maximum-output)))


;;; Tests

(def-slime-test package-updating
    (package-name nicknames)
    "Test if slime-lisp-package is updated."
    '(("COMMON-LISP" ("CL"))
      ("KEYWORD" ("" "KEYWORD" "||"))
      ("COMMON-LISP-USER" ("CL-USER")))
  (with-current-buffer (slime-output-buffer)
    (let ((p (slime-eval 
              `(swank:listener-eval 
                ,(format 
                  "(cl:setq cl:*print-case* :upcase)
                   (cl:setq cl:*package* (cl:find-package %S))
                   (cl:package-name cl:*package*)" package-name))
              (slime-lisp-package))))
      (slime-check ("slime-lisp-package is %S." package-name)
        (equal (slime-lisp-package) package-name))
      (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames)
        (member (slime-lisp-package-prompt-string) nicknames)))))

(defmacro with-canonicalized-slime-repl-buffer (&rest body)
  "Evaluate BODY within a fresh REPL buffer. The REPL prompt is
canonicalized to \"SWANK\"---we do actually switch to that
package, though."
  `(let ((%old-prompt% (slime-lisp-package-prompt-string)))
     (unwind-protect
          (progn (with-current-buffer (slime-output-buffer)
                   (setf (slime-lisp-package-prompt-string) "SWANK"))
                 (kill-buffer (slime-output-buffer))
                 (with-current-buffer (slime-output-buffer)
                   ,@body))
       (setf (slime-lisp-package-prompt-string) %old-prompt%))))

(put 'with-canonicalized-slime-repl-buffer 'lisp-indent-function 0)

(def-slime-test repl-test
    (input result-contents)
    "Test simple commands in the minibuffer."
    '(("(+ 1 2)" "SWANK> (+ 1 2)
{}3
SWANK> *[]")
      ("(princ 10)" "SWANK> (princ 10)
{10
}10
SWANK> *[]")
      ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
{1020
}20
SWANK> *[]")
      ("(dotimes (i 10 77) (princ i) (terpri))" 
       "SWANK> (dotimes (i 10 77) (princ i) (terpri))
{0
1
2
3
4
5
6
7
8
9
}77
SWANK> *[]")
      ("(abort)" "SWANK> (abort)
{}; Evaluation aborted.
SWANK> *[]")
      ("(progn (princ 10) (force-output) (abort))" 
       "SWANK> (progn (princ 10) (force-output) (abort))
{10}; Evaluation aborted.
SWANK> *[]")
      ("(progn (princ 10) (abort))" 
       ;; output can be flushed after aborting
       "SWANK> (progn (princ 10) (abort))
{10}; Evaluation aborted.
SWANK> *[]")
      ("(if (fresh-line) 1 0)"
       "SWANK> (if (fresh-line) 1 0)
{
}1
SWANK> *[]")
      ("(values 1 2 3)" "SWANK> (values 1 2 3)
{}1
2
3
SWANK> *[]")
      ("(with-standard-io-syntax
         (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
       "SWANK> (with-standard-io-syntax
         (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
 (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
}0
SWANK> *[]")
      ;; Two times to test the effect of FRESH-LINE.
      ("(with-standard-io-syntax
         (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
       "SWANK> (with-standard-io-syntax
         (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
 (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
}0
SWANK> *[]"))
  (with-canonicalized-slime-repl-buffer
    (insert input)
    (slime-check-buffer-contents "Buffer contains input" 
                                 (concat "{}SWANK> [" input "*]"))
    (call-interactively 'slime-repl-return)
    (slime-sync-to-top-level 5)
    (slime-check-buffer-contents "Buffer contains result" result-contents)))

(defun slime-check-buffer-contents (msg expected)
  (let* ((marks '((point . ?*) 
                  (slime-output-start . ?{) (slime-output-end . ?}) 
                  (slime-repl-input-start-mark . ?\[) (point-max . ?\])))
         (marks (remove-if-not (lambda (m) (position (cdr m) expected))
                               marks))
         (marks (sort (copy-sequence marks) 
                      (lambda (x y)
                        (< (position (cdr x) expected)
                           (position (cdr y) expected)))))
         (content (remove-if (lambda (c) (member* c marks :key #'cdr))
                             expected))
         (marks (do ((result '() (acons (caar m) (1+ (position (cdar m) s))
                                        result))
                     (m marks (cdr m))
                     (s expected (remove* (cdar m) s)))
                    ((null m) (reverse result))))
         (point (point))
         (point-max (point-max)))
    (slime-test-expect (concat msg " [content]") content (buffer-string))
    (macrolet ((test-mark 
                (mark)
                `(when (assoc ',mark marks)
                   (slime-test-expect (format "%s [%s]" msg ',mark)
                                      (cdr (assoc ',mark marks))
                                      ,mark
                                      #'=))))
      (test-mark point)
      (test-mark slime-output-end)
      (test-mark slime-output-start)
      (test-mark slime-repl-input-start-mark)
      (test-mark point-max))))

(def-slime-test repl-return 
    (before after result-contents)
    "Test if slime-repl-return sends the correct protion to Lisp even
if point is not at the end of the line."
    '(("(+ 1 2)" "" "SWANK> (+ 1 2)
3
SWANK> ")
("(+ 1 " "2)" "SWANK> (+ 1 2)
3
SWANK> ")

("(+ 1\n" "2)" "SWANK> (+ 1
2)
3
SWANK> "))
  (with-canonicalized-slime-repl-buffer
    (insert before)
    (save-excursion (insert after))
    (slime-test-expect "Buffer contains input" 
                       (concat "SWANK> " before after)
                       (buffer-string))
    (call-interactively 'slime-repl-return)
    (slime-sync-to-top-level 5)
    (slime-test-expect "Buffer contains result" 
                       result-contents (buffer-string))))
  
(def-slime-test repl-read
    (prompt input result-contents)
    "Test simple commands in the minibuffer."
    '(("(read-line)" "foo" "SWANK> (values (read-line))
foo
\"foo\"
SWANK> ")
      ("(read-char)" "1" "SWANK> (values (read-char))
1
#\\1
SWANK> ")
      ("(read)" "(+ 2 3
4)" "SWANK> (values (read))
\(+ 2 3
4)
\(+ 2 3 4)
SWANK> "))
  (with-canonicalized-slime-repl-buffer
    (insert (format "(values %s)" prompt))
    (call-interactively 'slime-repl-return)
    (slime-wait-condition "reading" #'slime-reading-p 5)
    (insert input)
    (call-interactively 'slime-repl-return)
    (slime-sync-to-top-level 5)
    (slime-test-expect "Buffer contains result" 
                       result-contents (buffer-string))))

(def-slime-test repl-read-lines
    (command inputs final-contents)
    "Test reading multiple lines from the repl."
    '(("(list (read-line) (read-line) (read-line))" 
       ("a" "b" "c")
       "SWANK> (list (read-line) (read-line) (read-line))
a
b
c
\(\"a\" \"b\" \"c\")
SWANK> "))
  (with-canonicalized-slime-repl-buffer
    (insert command)
    (call-interactively 'slime-repl-return)
    (dolist (input inputs) 
      (slime-wait-condition "reading" #'slime-reading-p 5)
      (insert input)
      (call-interactively 'slime-repl-return))
    (slime-sync-to-top-level 5)
    (slime-test-expect "Buffer contains result"
                       final-contents 
                       (buffer-string)
                       #'equal)))

(def-slime-test repl-type-ahead
    (command input final-contents)
    "Ensure that user input is preserved correctly.
In particular, input inserted while waiting for a result."
    '(("(sleep 0.1)" "foo*" "SWANK> (sleep 0.1)
{}NIL
SWANK> [foo*]")
      ("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1)
{}NIL
SWANK> [*foo]")
      ("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort))
{}; Evaluation aborted.
SWANK> [*foo]"))
  (with-canonicalized-slime-repl-buffer
    (insert command)
    (call-interactively 'slime-repl-return)
    (save-excursion (insert (delete* ?* input)))
    (forward-char (position ?* input))
    (slime-sync-to-top-level 5)
    (slime-check-buffer-contents "Buffer contains result" final-contents)))


(def-slime-test interrupt-in-blocking-read
    ()
    "Let's see what happens if we interrupt a blocking read operation."
    '(())
  (slime-check-top-level)
  (with-canonicalized-slime-repl-buffer
    (insert "(read-char)")
    (call-interactively 'slime-repl-return)
    (slime-wait-condition "reading" #'slime-reading-p 5)
    (slime-interrupt)
    (slime-wait-condition "Debugger visible" 
                          (lambda () 
                            (and (slime-sldb-level= 1)
                                 (get-buffer-window (sldb-get-default-buffer))))
                          5)
    (with-current-buffer (sldb-get-default-buffer)
      (sldb-continue))
    (slime-wait-condition "reading" #'slime-reading-p 5)
    (with-current-buffer (slime-output-buffer)
      (insert "X")
      (call-interactively 'slime-repl-return)
      (slime-sync-to-top-level 5)
      (slime-test-expect "Buffer contains result" 
                         "SWANK> (read-char)
X
#\\X
SWANK> " (buffer-string)))))

(provide 'slime-repl)