;;; cat interactive / editing mode 
;;; the other side of the tunnel is emacs.cat

;; TODO: derive this from a lisp mode

(require 'newcomment)

;; utility functions
;; (why are these not in emacs??)
(defun word-at-point ()
  (save-excursion
    (forward-char)
    (backward-word 1)
    (let ((end (point)))
      (forward-word 1)
      (buffer-substring-no-properties (point) end))))

(defun line-at-point ()
  (save-excursion
    (beginning-of-line)
    (let ((start (point)))
      (end-of-line)
      (buffer-substring-no-properties start (point)))))

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

(defun beginning-of-word ()
  (forward-char 1)
  (backward-word 1))

(defun cat-forward-definition  () (interactive) 
  (forward-word 1)
  (while 
      (not (string-equal ";" (word-at-point)))
    (forward-word 1)))

(defun cat-backward-definition () (interactive) 
  (backward-word 1)
  (while 
      (and (not (string-equal ":" (word-at-point)))
	   (> (point) 1))
    (backward-word 1)))


(defun definition-at-point ()
  (save-excursion
    (forward-char 1)
    (cat-backward-definition)
    (let ((start (point)))
      (cat-forward-definition)
      (buffer-substring-no-properties start (point)))))



(defun cat-comint-name () "cat-interaction")

;; buffer and interaction
(defun cat-buffer ()
  "get cat buffer"
  (get-buffer (concat "*" (cat-comint-name) "*")))

(defun cat-process () (interactive)
  "Get current cat process. If there is none, try to spawn one."
  (let ((process (get-buffer-process (cat-buffer))))
    (if process process
      (progn
	(cat-start-process)
	(get-buffer-process (cat-buffer))))))


(defun cat-interpreter () 
  "mzscheme"
;;  "guile"
  )

(defun cat-start-module (module) (interactive)
 (message "starting CAT...")
 (make-comint "cat-interaction" "brood" nil 
	      (cat-interpreter) module)

;;  (make-comint "cat" "/home/tom/bin/purrr")

;;   (make-comint "cat" "ssh" nil 
;; 	       "-p" "22" "-t" "localhost" 
;; 	       "brood/bin/brood" "-e" module)

  (set-process-filter (cat-process) 'cat-output-filter)
  (process-send-string (cat-process) "load-emacs\n")
  (message "")
  (save-excursion
    (set-buffer (cat-buffer))
    (cat-interactive-mode)))

(defun cat-start-process () (interactive)
  (cat-start-module "(load-cat)"))

(defun cat () (interactive)
  "Start interactive cat session."
  (if (not (cat-process))
      (cat-start-process))
  (switch-to-buffer (cat-buffer)))

(defun 18f () (interactive)
  (cat-start-module "(load-18f)")
  (switch-to-buffer (cat-buffer)))
  
(defun poke () (interactive)
  (cat-start-module "(load-poke)")
  (switch-to-buffer (cat-buffer)))
  
		    



;; SEND (visible)

;; string sending
(defun cat-send-string (command)
  "Send a string to the CAT interaction buffer."
  (save-excursion
    (set-buffer (cat-buffer))
    (comint-kill-input)
    (insert command)
    (comint-send-input)))

;; buffer substring sending
(defun cat-send-buffer-substring (start end)
  "Send a substring of current buffer to the CAT interaction buffer."
  (interactive "r")
  (let ((buf (current-buffer)))
    (save-excursion
      (set-buffer (cat-buffer))
      (insert-buffer-substring buf start end)
      (comint-send-input))))


(defun cat-send-word-at-point ()
  "Send word at point to the CAT interaction buffer."
  (interactive) (cat-send-string (word-at-point)))

(defun cat-send-line-at-point ()
  "Send line at point to the CAT interaction buffer."
  (interactive) (cat-send-string (line-at-point)))

(defun cat-send-definition-at-point ()
  "Send definition at point to the CAT interaction buffer."
  (interactive) (cat-send-string (definition-at-point)))








;; RECEIVE

; output filter storage
(defvar cat-output "")
(defvar cat-emacs-id "emacs:")


; interpret a line of cat output
; and eval expressions in "emacs:<exp>"
(defun cat-check-line (str)
  (if (string-match (concat "^" cat-emacs-id) str)
      (eval (car
	     (read-from-string 
	      (substring str (length cat-emacs-id)))))
    (comint-output-filter (cat-process) str)))
    

; sync variable
(defvar cat-waiting nil)

; check cat-output and process line by line
(defun cat-check-transaction ()

  ;; 1. check whole lines: if command, do eval, else send to buffer
  (while (string-match "^.*\n" cat-output)
    (let* ((p    (match-end 0))
	   (head (substring cat-output 0 p))
	   (tail (substring cat-output p (length cat-output))))
      (set-variable 'cat-output tail)
      (cat-check-line head)))

  ;; 2. check partial lines: if no command, flush to buffer anyway
  (if (and (length cat-output)
	   (not (string-match "^emacs:"  cat-output)))
      (progn
	(comint-output-filter (cat-process) cat-output)
	(set-variable 'cat-output ""))))

  


; filter: pass to accumulate
(defun cat-output-filter (proc string)
  (set-variable 'cat-output (concat cat-output string))
  (cat-check-transaction)
  (set-variable 'cat-waiting nil))


;; SEND (invisible)

(defun cat-command-string (command)
  "Send a string directly to the process."
  (process-send-string (cat-process) 
		       (concat command "\n")))

(defun cat-command-list (lst)
  (cat-command-string
   (concat
    (with-output-to-string (print lst))
    " run")))

;; COMMAND COMPLETION

(defun cat-wait-for-command ()
  (set-variable 'cat-waiting 1)
  (while cat-waiting
    (accept-process-output (cat-process) 1 1)))

(defun cat-complete ()
  "Perform completion on the cat symbol preceding point."
  (interactive)
  (save-excursion
    (let ((word (word-before-point)))
      (message (concat "completing: " word))
      (cat-command-list `(,word wordlist emacs-complete-reply))
      (cat-wait-for-command))))

(defun cat-help-word-at-point ()
  "Print documentation string of word under point in minibuffer."
  (interactive)
  (let ((word (word-at-point)))
    (cat-command-list `(,word emacs-help))))


(defun cat-complete-answer (word lst)
  (if (eq 'sole 
	  (comint-dynamic-simple-complete word lst))
      (let ((cbuf (get-buffer "*Completions*")))
	(if cbuf (kill-buffer cbuf)))))

;; DOCUMENTATION





  

;; some global key bindings
;(global-set-key [f4] 'cat-send-current-line)
;(global-set-key [C-return] 'cat-send-current-line)
;(global-set-key [M-return] 'cat-send-current-word)

;(global-set-key [f5] 'cat)
;(global-set-key [f6] 'cat-send-region)


;; MODES

; see http://two-wugs.net/emacs/mode-tutorial.html
(defvar cat-mode-hook nil)


(defconst cat-font-lock-keywords
  (list
;;    '("\\W:\\W" . font-lock-keyword-face)
;;    '("\\W;\\W" . font-lock-keyword-face)
;;    '("\\Wfor\\W" . font-lock-keyword-face)
;;    '("\\Wnext\\W" . font-lock-keyword-face)
   ))



(defvar cat-syntax-table (make-syntax-table))

(defun cat-init-syntax-table (table)

  ;; start with a clean sheet.
  (let ((character 0))
    (while (< character 255)
      (modify-syntax-entry character "w" table)
      (setq character (+ 1 character))))

  ;; whitespace
  (modify-syntax-entry ?\  " " table)
  (modify-syntax-entry ?\t " " table)

  ;; comment
  (modify-syntax-entry ?# "<" table)
  (modify-syntax-entry ?\n ">" table)
  (modify-syntax-entry ?\f ">" table)

  ;; string & escape
  (modify-syntax-entry ?\" "\"" table)
  (modify-syntax-entry ?\\ "\\" table)

  ;; list
  (modify-syntax-entry ?\( "()" table)
  (modify-syntax-entry ?\) ")(" table)

  ;; definitions.. this is way too ugly
  ;(modify-syntax-entry ?\: "(;"table ) 
  ;(modify-syntax-entry ?\; "):"table )

  )

(cat-init-syntax-table cat-syntax-table)



(defun cat-mode-shared ()
  ;; syntax table
  (set-syntax-table cat-syntax-table)

  ;; comment
  (make-local-variable 'comment-start)
  (setq comment-start "# ")

  ;; keywords
  (set (make-local-variable 
  	'font-lock-defaults) 
       '(cat-font-lock-keywords)))

  


;; interactive mode  
(define-derived-mode cat-interactive-mode comint-mode "CAT-interaction"
  "Packet Forth interaction mode"

  ;; shared stuff
  (cat-mode-shared))

(define-key cat-interactive-mode-map [M-tab] 'cat-complete)
(define-key cat-interactive-mode-map "\C-c\C-h" 'cat-help-word-at-point)

  

;; editing mode
(define-derived-mode cat-mode fundamental-mode "CAT"
  "Major mode for editing packet forth files."
;  (set (make-local-variable 'indent-line-function) '(cat-indent-line))

  ;; shared stuff
  (cat-mode-shared)

  ;; keymap
  (use-local-map cat-mode-map))
  
;; keymap
;(defvar cat-mode-map (make-sparse-keymap))
(set-keymap-parent cat-mode-map text-mode-map)

(define-key cat-mode-map [M-tab] 'cat-complete)
(define-key cat-mode-map "\C-c\C-l" 'cat-send-line-at-point)
(define-key cat-mode-map "\C-c\C-j" 'cat-send-word-at-point)
(define-key cat-mode-map "\C-c\C-d" 'cat-send-definition-at-point)
(define-key cat-mode-map "\C-c\C-h" 'cat-help-word-at-point)
(define-key cat-mode-map "\C-\M-f" 'cat-forward-definition)
(define-key cat-mode-map "\C-\M-b" 'cat-backward-definition)





(add-to-list 'auto-mode-alist '("\\.cat\\'" . cat-mode))



(provide 'cat)


;; TESTING

(defun cat-test () (interactive) (message (definition-at-point)))
(global-set-key [M-f9] 'cat-test)