;;;
;;; Copyright (C) 2004 Peter Graves
;;; $Id: slime.lisp,v 1.26 2004/09/21 13:53:08 piso Exp $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
;;; Further adapted by Brad Beveridge in 2006 to be integrated with Slim-Vim
;;; and be compatible with modern slime (v2.0)

(in-package :slime)

; (load "glue") ; TODO take the useful stuff from here and put it in the right place

(defvar *stream* nil) ; TODO rename to something more specific
(defvar *dedicated-io-stream* nil) ; TODO only really need the stream

(defvar *continuation-counter* 0)

(defvar *rex-continuations* nil)

(defvar *continuations-lock* (glue:make-mutex))

(defvar *repl-buffer-name* nil) ; TODO hardcode this

; Assume that slime is always remote
(defun local-p ()
 nil)

(defun connected-p ()
  (or (not (null *stream*))
      (local-p)))

(defun disconnect (&optional terminate)
  (when *stream*
    (vim:remove-input-listener *stream*)
    (close *stream*)
    (setf *stream* nil))
  (when *dedicated-io-stream*
    (vim:remove-input-listener *dedicated-io-stream*)
    (close *dedicated-io-stream*)
    (setf *dedicated-io-stream* nil))
  (setf *rex-continuations* nil)
  (when (and terminate vim-slime::*slime-pid*)
    (interface:slime-send-sigterm vim-slime::*slime-pid*)))

(defun connect (host port)
  (unless *stream*
    (let* ((socket (interface:connect-socket host port))
	   (stream (and socket (interface:make-socket-io-stream socket))))
      (format t "Connecting to ~A ~A socket: ~A stream: ~A~%" host port socket stream)
      (when stream
	(setf *stream* stream)
        (process-available-input stream)
	(vim:add-input-listener stream #'process-available-input)
	t))))

#|
(defun net-test ()
 (loop while (listen *stream*) do
  (let ((message (swank-protocol:decode-message *stream*)))
   (format vim-slime::*vim-output-buffer* "~A~%" message))))
|#

;TODO
(defun open-stream-to-lisp (port)
  "Opens an IO (?) Stream to Swank, this is for *standard-output* redirection
  from Swank, ie - (format t...) comes in here
  This is nothing to do with evaluating stuff in Swank"
  (format t "open-stream-to-lisp on ~A~%" port)
  (let* ((socket (connect-socket "127.0.0.1" port))
         (stream (and socket (make-socket-io-stream socket))))
    (when stream
      (setf *dedicated-io-stream* stream)
      ;(process-dedicated-output-stream stream)
      (vim:add-input-listener stream #'process-dedicated-output-stream))
    ))

; TODO - read the secret file for the port number
(defun read-port-and-connect (retries)
  (glue:status "Slime polling for connection...")
  (dotimes (i retries (glue:status "Slime timed out"))
    ;(unless (buffer-live-p *repl-buffer*)
      ;(glue:status "Killed")
      ;(return))
    ;(when (probe-file (swank-protocol:port-file))
      (let ((port 4005))
        (when (connect "127.0.0.1" port)
          (glue:status "Slime connected!")
          (get-connection-info #'process-connection-info)
          (return)))
     ;)
    (sleep 1)))

(defvar *swank-pid* nil)
(defvar *swank-communications-style* nil)
(defvar *swank-lisp-features* nil)

(defun process-connection-info (info)
  (destructuring-bind (&key pid style lisp-implementation machine
                            features package) info
    (setf *swank-pid* pid
          *swank-communications-style* style
          *swank-lisp-features* features)))

(defvar *io-callback-func* nil)

(defun set-io-callback (callback)
 "Callback must accept either a string or nil.  Nil means that there is no more output right now"
 (setf *io-callback-func* callback))

(defun busy-p ()
  (not (null *rex-continuations*)))

(defun current-package ()
 (package-name *package*))

(defvar current-thread t)

; todo - package support is incorrect for the swank end, is it still??
(defmacro rex ((&rest saved-vars)
	       (sexp &optional
		     (package '(current-package))
		     (thread 'current-thread))
	       &rest continuations)
   "(rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)

   Remote EXecute SEXP.

   VARs are a list of saved variables visible in the other forms.  Each
   VAR is either a symbol or a list (VAR INIT-VALUE).

   SEXP is evaluated and the princed version is sent to Lisp.

   PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
   The default value is (current-package).

   CLAUSES is a list of patterns with same syntax as `destructure-case'.
   The result of the evaluation is dispatched on CLAUSES.  The result is
   either a sexp of the form (:ok VALUE) or (:abort).  CLAUSES is
   executed asynchronously."
  (let ((result (gensym)))
    `(let ,(loop for var in saved-vars
                         collect (etypecase var
                                   (symbol (list var var))
                                   (cons var)))
       (dispatch-event
        (list :emacs-rex ,sexp ,package ,thread
              (lambda (,result)
                (glue:destructure-case ,result
                  ,@continuations)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; It is turning out that these functions are useful to be exported
;; TODO - fix all the packages, make it non-optional
(defun slime-eval (sexp &optional package)
  (rex () (sexp package)
       ((:ok result) 
	(format t "Continuation1 called :ok~%")
	(vim:msg (format nil "Result ~a" result))
	(format vim-slime::*vim-repl-buffer* "~A~%" result)
	(ecl-slime::setup-repl))
       ((:abort) (format t "Continuation2 called :abort~%"))))

(defun eval-async (sexp &optional cont package)
  "Evaluate SEXP on Swank and call cont with the result"
  (rex () (sexp package)
       ((:ok result)
	(when cont (funcall cont result)))
       ((:abort) 
	(format t "Continuation3 called :abort~%")
	(vim-slime::setup-repl))))

(defun listener-eval (form-string callback package)
  (rex () (`(swank:listener-eval ,form-string) package :repl-thread)
       ((:ok result)
	(when callback (funcall callback result)))
       ((:abort) (format t "Continuation4 called :abort~%"))))

; TODO - make these optional packages call a frontend interface func?
(defun interactive-eval (form-string callback &optional (pack (current-package)))
  (assert (stringp form-string))
  (format t "SIE got ~s~%" form-string)
  (eval-async `(swank:interactive-eval ,form-string) callback pack))

(defun re-evaluate-defvar (form &optional (pack (current-package)))
 (slime-eval `(swank:re-evaluate-defvar ,form) pack))

(defun slime-compile-file (lisp-filename callback &optional load)
 (eval-async `(swank:compile-file-for-emacs
               ,lisp-filename ,(if load t nil)) callback nil))

; TODO - not working really
(defun compile-string (string start-offset buffer-name buffer-directory package)
 (slime-eval
  `(swank:compile-string-for-emacs ,string ,buffer-name ,start-offset ,buffer-directory) package))

; Get the compiler notes
(defun compiler-notes (callback)
 (eval-async `(swank:compiler-notes-for-emacs) callback))

; See echo-arglist.  The callback is called when swank responds
(defun get-arglist (names package callback)
 (let ((name-list (if (listp names) names (list names))))
  (rex () (`(swank:arglist-for-echo-area (quote ,name-list)) package)
   ((:ok value) (when callback (funcall callback value)))
   ((:abort) (format t "get-arglist got an abort!  TODO!~%")))))

(defun sldb-frame-locals (frame callback)
 (eval-async `(swank:frame-locals-for-emacs ,frame) callback))

(defun slime-inspect (form callback &optional (pack (current-package)))
 (eval-async `(swank:init-inspector ,form) callback pack))

(defun sldb-invoke-restart (number)
  (when (slime::connected-p)
    (rex () ((list 'swank::invoke-nth-restart-for-emacs interface::*sldb-level* number)
	     nil interface::*sldb-thread*)
      ((:ok value) (format t "Restart returned: ~s" value))
      ((:abort)))))

(defun sldb-quit ()
 (slime-eval '(swank:throw-to-toplevel)))

(defun get-connection-info (callback)
 (eval-async '(swank:connection-info) callback nil))

(defun send-sigint ()
 (interface:slime-send-sigint *swank-pid*))

(defvar *eval-macroexpand-expression* nil)
(defun eval-macroexpand (expander form callback package)
 "Helper function for macroexpanding"
 (setf *eval-macroexpand-expression* `(,expander ,form))
 (eval-async *eval-macroexpand-expression* callback package))

(defun macroexpand-1 (form callback package)
 (eval-macroexpand 'swank:swank-macroexpand-1 form callback package))

(defun macroexpand-all (form callback package)
 (eval-macroexpand 'swank:swank-macroexpand-all form callback package))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;TODO only Synchronous right now
; TODO, rename swank-protocol:encode-message -> slime:send
(defun dispatch-event (event)
  "This function is not only for reading from Swank, but for sending to it also"
  (let ((*standard-output* vim-slime::*vim-output-buffer*))
    ;(format t "dispatch-event ~a~%" event)

    (when event
      (glue:destructure-case event
	((:open-dedicated-output-stream port)
	 (open-stream-to-lisp port)
	 (format t "Back from open-stream-to-lisp~%"))

	;; :emacs-rex is a >swank form
	((:emacs-rex form package thread continuation)
	 (let ((id (incf *continuation-counter*)))
	   (push (cons id continuation) *rex-continuations*)
	   (swank-protocol:encode-message `(:emacs-rex ,form ,package, thread, id) *stream*)))

	((:return value id)
	 (let ((rec (assoc id *rex-continuations*)))
	   (cond
	     (rec (setf *rex-continuations*
			(remove rec *rex-continuations*))
		  (funcall (cdr rec) value))
	     (t (format t "!!Unexpected return~%"))))
	 ;(format t "interactive-eval :return ~A" (glue:prin1-to-string-for-emacs (cadr (cadr event))) )
	 )

	((:debug thread level condition restarts frames conts)
	 (assert thread)
	 (interface:sldb-setup thread level condition restarts frames conts))

	((:debug-activate thread level)
	 (assert thread)
	 (interface:sldb-activate thread level))

	((:debug-return thread level stepping)
	 (interface:sldb-exit thread level stepping)
	 (format t ":debug-return ~%~A~%" (glue:prin1-to-string-for-emacs event)))
	((:new-package package prompt-string)
	 (interface:new-listener-package package prompt-string))
        ((:emacs-interrupt thread)
         (cond ((use-sigint-for-interrupt) (send-sigint))
               (t (swank-protocol:encode-message `(:emacs-interrupt ,thread) *stream*))))

	;; Below here is not really supported just yet
	((:read-string thread tag)
	 (repl-read-string thread tag))
	((:emacs-return-string thread tag string)
	 (swank-protocol:encode-message `(:emacs-return-string ,thread ,tag ,string) *stream*))
	((:write-string &rest args)
	 (format t "write-string ~A" (glue:prin1-to-string-for-emacs event)))
	((:indentation-update alist)
	 (interface:handle-indentation-update alist))
	((:new-features &rest args) (format t "indent update ~A~%" (glue:prin1-to-string-for-emacs event)))))))

#|
(defun test () (vim:msg "hllo"))
(test)
(slime::interactive-eval "(+ 1 14)")
(in-package #:slime)
(vim:add-input-listener *stream* #'net-test)
(+ 16 1)
(format nil "hello")
(format t "~A~%" *sldb-level*)
(sldb-invoke-restart 0)
(vim:replace-lines nil :buffer (vim:find-buffer "--slim-vim--"))
|#

(defvar *input*
  (make-array 1024 :element-type 'base-char :fill-pointer 0 :adjustable t))

(defvar *dedicated-input-buffer*
  (make-array 1024 :element-type 'base-char :fill-pointer 0 :adjustable t))

(defun process-available-input (stream)
  (ignore-errors
    (loop for ch = (read-char-no-hang stream nil :eof)
	  while ch do
	  (cond
	    ((eq ch :eof) (disconnect))
	    (ch (vector-push-extend ch *input*))))
    (loop for message = (swank-protocol:decode-message *input*)
	  while message
	  do (dispatch-event message))
    t)
  )

(defun process-dedicated-output-stream (stream)
  (ignore-errors
    (loop for ch = (read-char-no-hang stream nil :eof)
	  while ch do
	  (cond
	    ((eq ch :eof) (disconnect))
	    (ch (vector-push-extend ch *dedicated-input-buffer*))))
    (funcall *io-callback-func* *dedicated-input-buffer*)
    (setf (fill-pointer *dedicated-input-buffer*) 0)
    t)
  )

(defvar *read-string-threads* nil)
(defvar *read-string-tags* nil)

;; This only works in the GUI version (and maybe only in the X-GUI version).
(defun repl-read-string (thread tag)
  (push thread *read-string-threads*)
  (push tag *read-string-tags*)
  (repl-return-string 
    (concatenate 'string 
		 (vim:input "Enter a value: ") 
		 (string #\Newline))))

(defun repl-return-string (string)
  (format vim-slime::*vim-repl-buffer* "~A" string)
  (dispatch-event `(:emacs-return-string 
                          ,(pop *read-string-threads*)
                          ,(pop *read-string-tags*)
                          ,string))
  ; (slime-repl-read-mode -1)
  )

(defun repl-abort-read (thread tag)
    (pop *read-string-threads*)
    (pop *read-string-tags*)
    (vim:msg "Read aborted"))