;; snot.el --- repl for inferior lisp written in Emacs Lisp
;; (c) Tom Schouten 2007

;; Not much of the original ielm.el source is left, but that's where I
;; started from. The licence is GPL, see the file ielm.el, part of GNU
;; Emacs.

;; You should have received this with `snot.ss', an mzscheme module
;; implementing the other end of the pipe. The idea is to implement
;; most of the logic on the scheme side, and leave the emacs side as a
;; stateless view (MVC).


;; TODO:

;; * check cases where read syntax still gives problems, mainly in
;;   strings with non-ascii content.

;; * should be minor mode: lisp, forth and cat code should have proper
;;   completions from one entry to the running scheme interpreter.



;;; Code:

(require 'comint)
(require 'pp)
(require 'cl)


;;; CONFIG

;; Find the scheme file in the emacs load path. FIXME: there has to be
;; a highlevel routine for this.

(defun snot-load-ss ()
  (let ((path load-path)
	(filename))
    (while (and path (not filename))
      (let ((full 
	     (concat (pop path) 
		     "snot-load.ss")))
	(if (file-exists-p full)
	    (setq filename full))

	))
    filename))

;;; STATE

;; To keep things simple:

;; * The emacs side of snot is gui only.

;; * There is only one snot process per emacs session.  It's easier to
;;   have multiple processes run in PLT scheme than in emacs.


;; Customization

(defvar snot-mode-hook nil)



;; KEYMAP

(defvar snot-map nil)
(if snot-map nil
  (progn
    (setq snot-map (cons 'keymap comint-mode-map))

    ;; these are from my personal stash..
    ;; (define-key snot-map "[" 'insert-parentheses)
    ;; (define-key snot-map "]" 'move-past-close-and-reindent)
    (define-key snot-map "\M-p" 'comint-next-prompt)
    (define-key snot-map "\M-u" 'comint-previous-prompt)

    ;; standard bindings
    (define-key snot-map "\t" 'comint-dynamic-complete)
    (define-key snot-map "\C-m" 'snot-return)
    (define-key snot-map "\e\i" 'snot-previous-language)
    (define-key snot-map "\e\o" 'snot-next-language)
    (define-key snot-map "\C-j" 'snot-comint-send-input)
    (define-key snot-map "\C-d" 'snot-delete-char)
    (define-key snot-map "\e\C-x" 'snot-eval-define)   ; for consistency with
    (define-key snot-map "\e\t" 'snot-complete-symbol-current) ; lisp-interaction-mode
    ;; These bindings are from `lisp-mode-shared-map' -- can you inherit
    ;; from more than one keymap??
    (define-key snot-map "\e\C-q" 'indent-sexp)
    (define-key snot-map "\177" 'backward-delete-char-untabify)))

(defvar snot-font-lock-keywords
  (list
   '("^\\W>" . font-lock-keyword-face)
   '("\\(^\\*\\*\\*[^*]+\\*\\*\\*\\)\\(.*$\\)" 
     (1 font-lock-comment-face)
     (2 font-lock-constant-face)))
  "Additional expressions to highlight in snot buffers.")


;; MISC UTIL

(defun snot-is-whitespace (string)
  "Return non-nil if STRING is all whitespace."
  (or (string= string "") (string-match "\\`[ \t\n]+\\'" string)))



;; VIEW UPDATE

(defun snot-update-prompt (prompt)
  "All repl state is saved on the scheme end. What we do here is
  just stateless view. Whenever the internal language changes, we
  get called to update comint state etc..."

;  (setq comint-prompt-regexp "^.*> ")

  (setq comint-prompt-regexp 
	(concat "^" (regexp-quote prompt)))
  )

  


;;; BUFFER / PROCESS

(defun snot-process-name () "snot")

(defun snot-buffer-name () 
  (format "*%s*" (snot-process-name)))

(defun snot-sub-buffer-name (str) 
  (format "*%s-%s*" (snot-process-name) str))


(defun snot-start-process ()
  (start-process (snot-process-name) snot-buffer
		 "racket" "-p" "zwizwa/snot/start"))
(defun snot-running-p ()
  (let ((buffer (get-buffer (snot-buffer-name))))
    (comint-check-proc buffer)))



(defvar snot-buffer nil)
(defvar snot-msg-buffer nil)
(defvar snot-log-buffer nil)

(defun snot-process ()   (get-buffer-process snot-buffer))
(defun snot-pm ()        (process-mark (snot-process)))
(defun snot-set-pm (pos) (set-marker (process-mark (snot-process)) pos))

  

;; COMPLETION

(defun snot-tab nil
  "Possibly indent the current line as lisp code."
  (interactive)
  (if (or (eq (preceding-char) ?\n)
	  (eq (char-syntax (preceding-char)) ? ))
      (progn
	(snot-indent-line)
	t)))


(defun snot-word-before-point ()
 (let ((end (point)))
   (save-excursion
     (skip-syntax-backward "w_")
     (buffer-substring-no-properties (point) end))))


(defun snot-complete-symbol-language (language)
  "Complete the target `language' symbol before point."
  (let* 
      ((fragment 				 
	(snot-word-before-point))
       (wordlist 
	(snot-eval 
	 `(language-complete ',language ,fragment))))
    (comint-dynamic-simple-complete fragment wordlist)))

(defun snot-complete-symbol-current nil
  (interactive)
  (snot-complete-symbol-language 'current))


(defun snot-complete-symbol-scheme nil
  "Complete a scheme symbol. If the boxed evaluator is available,
  use that. Otherwize fall back on the toplevel."
  (interactive)
  (snot-complete-symbol-language 'box))



(defun snot-complete-filename nil
  (interactive)
  "Dynamically complete filename before point, if in a string."
  (if (nth 3 (parse-partial-sexp comint-last-input-start (point)))
      (let ((default-directory
	      (format "%s/"
                      (snot-eval 
                       '(language-eval 'current '(current-directory)))
		      ;; (snot-eval '(current-directory))
                      )))
	(comint-dynamic-complete-filename))))


(defun snot-indent-line nil
  "Indent the current line as Lisp code if it is not a prompt line."
  (when (save-excursion (comint-bol) (bolp))
    (lisp-indent-line)))



;;; KEY ACTIONS

(defun snot-delete-char ()
  (interactive)
  (delete-char 1))
  

(defun snot-at-point ()
  (interactive)
  (let ((it (thing-at-point 'sexp)))
    (message (format "%s" it))))

(defun snot-return nil
  "Evaluate the sexp before the prompt or copy old input."
  (interactive)

  ;; check if it's new input
  (if (<= (snot-pm) (point))
      (snot-comint-send-input)
    
    ;; if old input, copy it
    (comint-copy-old-input)))


(defun snot-next-language () 
  (interactive) 
  (snot-eval '(begin 
	       (next-language)
	       (emacs-display "\n")
	       (emacs-display-prompt))))

(defun snot-previous-language () 
  (interactive) 
  (snot-eval '(begin
	       (previous-language)
	       (emacs-display "\n")
	       (emacs-display-prompt))))



;;; MAJOR MODE

(put 'snot-mode 'mode-class 'special)


(defun snot-mode nil
  "Major mode for interacting with an inferior lisp using the SNOT protocol."
  (interactive)
  (comint-mode)
  (toggle-read-only -1) ;; returning from compilation-mode

  ;; RESET GLOBAL STATE
  (save-excursion
    (set-buffer snot-msg-buffer)
    (delete-region (point-min) (point-max)))

  
  (make-local-variable 'paragraph-start)
  (make-local-variable 'comint-dynamic-complete-functions)
  (make-local-variable 'comint-completion-addsuffix)
  (make-local-variable 'indent-line-function)
  (make-local-variable 'fill-paragraph-function)
  (make-local-variable 'font-lock-defaults)
  (make-local-variable 'comint-use-prompt-regexp)


  (setq comint-use-prompt-regexp t)
  (setq paragraph-start comint-prompt-regexp)
  (setq comint-input-sender 'snot-comint-input-sender)
  (setq comint-process-echoes nil)
  (setq comint-dynamic-complete-functions
	'(snot-tab ;; if prev char is whitespace, tab performs indent
	  ;; comint-replace-by-expanded-history 
	  snot-complete-filename ;; if in string, do filename
	  snot-complete-symbol-current))  ;; otherwize query process' current lang
  (setq comint-get-old-input 'snot-get-old-input)
  (setq comint-completion-addsuffix
	(cons (char-to-string directory-sep-char) ""))
  (setq indent-line-function 'snot-indent-line)
  (setq fill-paragraph-function 'lisp-fill-paragraph)

  (setq major-mode 'snot-mode)
  (setq mode-name "SNOT")

  (set-syntax-table emacs-lisp-mode-syntax-table)
  (use-local-map snot-map)

  (setq font-lock-defaults
	'(snot-font-lock-keywords nil nil ((?: . "w") (?- . "w") (?* . "w"))))

  ;; start process if not running
  (if (comint-check-proc snot-buffer) nil
    (snot-start-process)
    (process-kill-without-query (snot-process))
    (goto-char (point-max))
    (snot-set-pm (point-max))
    (goto-char (point-max))
    (set-marker comint-last-input-start (snot-pm))
    (set-process-filter (get-buffer-process snot-buffer) 'snot-catch-reply))

  (run-hooks 'snot-mode-hook)

  (snot-eval '(emacs-display-prompt))


)


(defun snot-get-old-input nil
  "Return the previous input surrounding point."
  (save-excursion
    (beginning-of-line)
    (if (looking-at comint-prompt-regexp) nil
      (re-search-backward comint-prompt-regexp))
    (comint-skip-prompt)
    (buffer-substring (point) (progn (forward-sexp 1) (point)))))


;;; BOOT

;;;###autoload (add-hook 'same-window-buffer-names (snot-buffer-name))

;;;###autoload

(defun snot-start ()
  "If no snot process is running, start it up in the background."
  (let* ((buffer (get-buffer-create (snot-buffer-name))))
    (setq snot-buffer buffer)
    (setq snot-msg-buffer (get-buffer-create (snot-sub-buffer-name "msg")))
    (setq snot-log-buffer (get-buffer-create (snot-sub-buffer-name "log")))
    (if (not (snot-running-p))
        (save-excursion
          (set-buffer buffer)
          (snot-mode)))))
      
(defun snot-other-window ()
  "Activates snot in another window."
  (interactive)
  (snot-start)
  (if (not (eq (current-buffer) 
	       snot-buffer))
      (switch-to-buffer-other-window snot-buffer)))

(defun snot ()
  "Switches to the buffer `*snot*', or creates it if it does not
exist."
  (interactive)
  (snot-start)
  (switch-to-buffer snot-buffer))


;; INTERACTION

(defun snot-send-module ()
  "Instead of sending definitions to a running process, it's
usually better to send a whole module. This function sends the
current mzscheme module to snot, and creates a new `module'
evaluator in the sandbox."
  (interactive)
  (snot-send-buffer (current-buffer)))

(defvar snot-last-buffer nil)

(defun snot-send-again ()
  (interactive)
  (if snot-last-buffer
      (snot-send-buffer snot-last-buffer)
    (message "No current snot module to send.")
    (snot-other-window)))

(defun snot-buffer-to-string (buffer begin end)
  (save-excursion
    (set-buffer buffer)
    (buffer-substring-no-properties
     (funcall begin) (funcall end))))

;(defun snot-forth-region ()
;  (interactive)
;  (let ((code (snot-buffer-to-string (current-buffer) 'mark 'point)))
;    (snot-eval
;     `(language-eval 'box
  

(defun snot-send-buffer (buffer)
  (let* ((bufname (buffer-name buffer))
         (code (snot-buffer-to-string buffer 'point-min 'point-max))
         (path  (buffer-file-name buffer)))
    (setq snot-last-buffer buffer)
    (snot-other-window)
    (goto-char (point-max))
    (snot-eval 
     `(thread  ;; load in background.
       (lambda ()
         (printf "\nmodule ~a (~a)\n" ,bufname ,path)
         (box-module-string ,(file-name-directory path) ,code)
         (emacs-display-prompt)
         )))))



(provide 'snot)

;;; snot.el ends here


;; what to do when idle

(defun snot-help ()
  (interactive)
  (let ((word (or (thing-at-point 'symbol))))
    (when word (snot-eval `(help ,(read word))))))


(defun snot-display-info ()
  (if (eq (current-buffer) snot-buffer)
      (save-excursion
        (backward-char)
        (let ((expr (snot-at-point)))
          (message expr)))))

(defun snot-start-idle ()
  (interactive)
  (run-with-idle-timer .1 t 'snot-display-info))
                       
;; (cancel-function-timers 'snot-display-info)


;; *** EMACS CHANNEL ***

;; Used to be a separate file snot-emacs-channel.el but moved here for
;; simpler handling.

;; Elisp side of an elisp <-> scheme reader channel.

;; This file implements the details of communication. The interface
;; provided is:

;; - snot-message      asynchronous message
;; - snot-eval         synchronous evaluation


;; for comint:

;; - snot-comint-input-sender
;; - snot-comint-send-input


;; EXPRESSION TRANSLATION


(defun snot-commands-value (retval)
  "Map return value expression to single value or throw error."

  (let ((tag (car retval))
	(msg (cdr retval)))

    (case tag
      ;; error -> throw it
      ((error) 
       (setq reply `(error ,(car msg)))
       (throw 'snot-eval-error (car msg)))
      
      ;; first value or 'void
      ((values)
       (car (append msg '(void)))))))

;; Scheme values that no or a different elisp reader representation
;; are wrapped in generating elisp expressions tagged with 'uq. This
;; function is called on the received expression right before it is
;; evaluated in the output filter.
(defun snot-unserialize (expr)
  (if (not (consp expr))
      expr
    (if (eq (car expr) 'uq)   
        (eval (cadr expr))
      (cons (snot-unserialize (car expr))
	    (snot-unserialize (cdr expr))))))

(defun snot-unserialize/eval (expr)
  (eval (snot-unserialize expr)))



;; LOWLEVEL COMMUNICATION

;; SEND

(defun snot-send-expression (chan expr)
  "Send a raw expression `expr' to be evaluated by the snot
process to a certain communication channel `chan'. The return
value this expression produces is ignored. If synchronous
evaluation is necessary, a continuation needs to be passed to the
function to be evaluated. See `snot-eval'. If no snot process is
running, one is started in the background."

  (snot-start)
  
  (let ((string (format "(%S %S)\n" chan expr)))
    (snot-debug-log (concat "SEND:\n" string))
    (process-send-string 
     (snot-process) string)))


(defun snot-poll ()
  "Poll all processes. Used in `snot-wait-reply'."
  (accept-process-output 
   nil ;; (snot-process) 
   0 100))



(defun snot-wait-reply ()
  "Block emacs until the snot process returns a reply."
  (snot-poll)
  (if (not reply)
      (while (not reply)
	;; (message "Waiting for snot process...  Hit C-g to cancel.")
	(snot-poll))))



;; CHANNELS

;; The high level interaction with the scheme process is limited to
;; these 2 communication channels. These are the only functions that
;; send raw expressions to the snot process.

;; SYNCHRONOUS EVAL (SEND + wait for RECEIVE)

(defun snot-eval (expr)
  "Send an s-expression to the snot process over the `eval'
channel, and wait for the result. Emacs is suspended until
evaluation is complete. The result is returned to
`snot-continue'. This is independent of REPL state."

  (let (reply) ;; nil = no answer, answer with no values = '(void)
    (snot-send-expression
     'eval
     `(eval/continue 'snot-continue ',expr))
    (snot-wait-reply)
    (snot-commands-value reply)))
  

;; ASYNCHRONOUS MESSAGE (SEND only)

(defun snot-message (expr)
  "Send an s-expression to the snot process over the `message' channel,
  and continue execution."
  (snot-send-expression
   'message expr))
   


;; COMINT INTERFACE

(defun snot-comint-input-sender (proc comint-input)
  "Just sets the dynamic variable `input', which is in the scope
  of `snot-comint-send-input's call. This is so we can control
  exactly what goes to the process: i.e. we need to always send
  s-expressions following the snot protocol, but at the same time
  piggyback on what 'comint-send-input' does."

  (setq snot-input comint-input))

(defun snot-comint-send-input nil
  "Evaluate the Emacs Lisp expression after the prompt."
  (interactive)
  (let ((buf snot-buffer)
	snot-input)		;; set by snot-comint-input-sender
    (comint-send-input t)	;; pdate history, markers etc.
    (snot-current-rep
     (substring-no-properties snot-input))))



;; The two mechanisms above can be used to perform different forms of
;; communication.

(defun snot-current-rep (str-expr)
  "The REPL uses `snot-message' to pass an input string to the
current language."

  (snot-message 
   `(begin
     (emacs-display "\n")  ;; the newline associated to <enter>
     (emacs-limit-output
      (lambda ()
        (language-rep 'current ,str-expr)))
     (emacs-display-prompt))))


 


;; RECEIVE

(defun snot-display (thing)
  "Sends a string to the buffer, through the comint filter."
  (save-current-buffer
    (set-buffer snot-buffer)
    (comint-output-filter (snot-process) thing)))


(defun snot-display-image (type data)
  "Sends an image to the buffer, through the comint filter."
  (let ((marker (snot-display "X")))
    (let ((pos (marker-position marker)))
      (message (format "%S" pos))
      (put-text-property (1- pos) pos 'display
                         `(image :data ,data
                                 :type ,type)))))

(defun snot-read-next ()
  (save-excursion
    (set-buffer snot-msg-buffer)
    (goto-char (point-min))
    (let ((expr (read (current-buffer))))
      (delete-region (point-min) (point))
      expr)))

(defvar snot-retries 0)  

(defun snot-try-buf ()
  "Gather expressions from reply buffer and evaluate them as elisp code."
  (while
      (condition-case err
          (progn (snot-unserialize/eval  ;; (*)
                  (snot-read-next))
                 ;; (message (format "%s" snot-retries))
                 (setq snot-retries 0)
                 t)
        (end-of-file ;; ignore incomplete parse
         (setq snot-retries (+ 1 snot-retries))
         '(message
           (save-excursion
             (set-buffer snot-msg-buffer)
             (buffer-substring-no-properties (point-min) (point-max))))
         nil))
    nil))

;; (*) This walks the s-expression and evaluates 'uq forms.  Not all
;; values can be transported directly into elisp s-expressions
;; (i.e. special characters in strings) so they are generated from
;; prgrammatic descriptions.


(defun snot-append (buffer string)
  (save-current-buffer
    (set-buffer buffer)
    (insert string)))

(defun snot-debug-log (str)
  (snot-append snot-log-buffer str))

(defun snot-catch-reply (proc string)
  "The output filter: concatenates output to reply buffer, and
invokes `snot-try-buf'."
  (snot-debug-log (concat "RECV:\n" string))
  (snot-append snot-msg-buffer string)
  (snot-try-buf))


(defun snot-continue (r)
  "Scheme calls back through this function. This will continue
  the operation that is waiting for a reply for a synchronous eval."
  (setq reply r))
    



;; IMAGES / VIDEO

;; Instead of using inline images, use a separate buffer to display
;; image output.

;; (defun snot-display-image (type data)
;;   "Sends an image to the buffer."
;;   (snot-display "") ;; SYNC?
;;   (save-excursion
;;     (set-buffer snot-buffer)
;;     (end-of-buffer)
;;     (insert-image (create-image data type t))))