;;; packet forth interactive / editing mode 
;;; the other side of the tunnel is emacs.pf

(require 'newcomment)


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

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

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

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

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


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



;; processes

(defun pf-daemon-process ()
  "Get current or spawn a PF server process."
  (let ((process (get-buffer-process "*pf-daemon*")))
    (if process process
      (let ((buffer (make-comint "pf-daemon" "pf" nil "-")))
	(process-send-string (pf-daemon-process) "load-emacs\n")
	(save-excursion
	  (set-buffer buffer)
	  (pf-interactive-mode))
	(sleep-for 100) ;; give it some time to bring up the socket
	(get-buffer-process buffer)))))

(defun pf-daemon-socket ()
  (concat "/tmp/pf-"
	  (number-to-string
	   (process-id (pf-daemon-process)))))

(defun pf-console-process ()
  "Get current or spawn a new PF console process."
  (pf-daemon-process) ;; make sure there is a daemon

  (let ((process (get-buffer-process "*pf*")))
    (if process process
      (let ((buffer (make-comint "pf" "socat" nil "-" (pf-daemon-socket))))
	(save-excursion
	  (set-buffer buffer)
	  (pf-interactive-mode)
	  (let ((process (get-buffer-process buffer)))
	    (setq comint-input-sender 'pf-input-send)
	    (set-process-filter process 'pf-output-filter)
	    process))))))

;; filters

(defun pf-sanitize (string)
  (replace-regexp-in-string 
   "\n" " " (string-as-unibyte string)))

(defvar pf-last-output "")


(defun pf-input-send (proc string)
  (let ((cmd (format "quoted %S interpret-string"
		 (pf-sanitize string))))
    (comint-simple-send proc cmd)))



(defun pf-output-filter (proc string)

  ;; save output
  (set-variable 'pf-last-output 
		(concat pf-last-output string))

  ;; check whole lines
  (while (string-match "^.*\n" pf-last-output)
    (let* ((p    (match-end 0))
	   (head (substring pf-last-output 0 p))
	   (tail (substring pf-last-output p (length pf-last-output))))
      (set-variable 'pf-last-output tail)
      (let ((expr (car (read-from-string head))))
	(if (stringp expr)
	    (comint-output-filter proc expr)
	  (eval-expression expr))))))




(defun pf () (interactive)
  "Start interactive pf session."
  (pf-daemon-process)
  (pf-console-process)
  (switch-to-buffer (get-buffer "*pf*")))


;; SEND (visible)

;; string/buffer sending

(defun with-pf (fn)
  (save-excursion
    (set-buffer (get-buffer "*pf*"))
    (funcall fn)))
  

(defun pf-send-string (command)
  "Send a string to the PF interaction buffer."
  (with-pf (lambda ()
	     (comint-kill-input)
	     (insert command)
	     (comint-send-input))))

;; buffer substring sending
(defun pf-send-buffer-substring (start end)
  "Send a substring of current buffer to the PF interaction buffer."
  (interactive "r")
  (let ((buf (current-buffer)))
    (with-pf (lambda ()
	       (insert-buffer-substring buf start end)
	       (comint-send-input)))))




(defun pf-send-region () (interactive)
  (pf-send-buffer-substring (mark) (point)))


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

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

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




;; SEND (invisible)

(defun pf-interpreter (command)
   (if (listp command) 'interpret-list 'interpret-string))

;; asynchronous messages

(defun pf-command (command)
  "Send a command directly to the PF process. (string or list).
The output generated will be inserted in the interaction buffer."
  (process-send-string
   (pf-console-process)
   (format "quoted %S %S\n" command (pf-interpreter command))))

(defun pf-message (receiver command)
   "Send a command directly to the PF process (string or list).
The output generated will be passed to the receiver."
   (process-send-string
    (pf-console-process)
    (format "quoted-receiver %S %S %S\n" 
	    receiver command (pf-interpreter command))))


;; dynamicly bound reply
(defun pf-dynamic-reply (thing)
  (set-variable 'reply thing))

(defun pf-wait-for-reply ()
  (while (not reply)
    (accept-process-output (pf-console-process) 1 1)))
  

;; synchronous messages
(defun pf-eval (command)
  "Run command and return the item on the top of the data stack."

  (let (reply) ;; will be set to non-nil when task is completed

    (pf-command command) ;; run command, we don't care about output
    (pf-message 'pf-dynamic-reply '(write)) ;; pass result to pf-reply function
    (pf-wait-for-reply)
    (car (read-from-string reply))))

(defun pf-to-string (command)
  (let (reply)
    (pf-message 'pf-dynamic-reply command)
    (pf-wait-for-reply)
    reply))

(defun pf-status ()
  (interactive)
  (message
   (let ((out (pf-to-string '(ps))))
     (substring out 0 (- (length out) 1)))))

    
;; COMMAND COMPLETION

(defun pf-tab ()
  "Possibly indent the current line as PF code."
  (interactive)
  (if (or (eq (preceding-char) ?\n)
	  (eq (char-syntax (preceding-char)) ? ))
      (progn
	(indent-for-tab-command)
	;; (insert "\t") ;; FIXME: pf-indent-line
	t)))


(defun pf-pm ()
  (process-mark (pf-console-process)))

(defun pf-enter ()
  (interactive)
  (let ((state
	 (save-excursion
	   (end-of-line)
	   (parse-partial-sexp (pf-pm)
			       (point)))))
    (if (and (< (car state) 1)    ;; sexp depth
	     (not (nth 3 state))) ;; not inside a string
	(progn
	  (comint-send-input)
	  ;; (pf-status)  ;; annoying: display disappears
	  )

      (newline-and-indent))))



(defun pf-complete-symbol ()
  "Perform completion on the pf symbol preceding point."
  (interactive)
  (let ((comint-completion-addsuffix
	 (cons (char-to-string directory-sep-char) " ")))
    (let ((words (pf-eval '(emacs-words))))
      (comint-dynamic-simple-complete (pf-word-before-point) words))))

(defun pf-complete-filename ()
  "Dynamically complete filename before point, if in a string."
  (if (nth 3 (parse-partial-sexp comint-last-input-start (point)))
      (let ((comint-completion-fignore
	     '("~"))
	    (comint-completion-addsuffix
	     (cons (char-to-string directory-sep-char) "\" ")))

	(comint-dynamic-complete-filename))))
  
;;	     

;; DOCUMENTATION

(defun pf-help-word (word)
  "Return docimentation string of PF word."
  (pf-eval (format "' %s docstring" word)))


(defun pf-help-word-at-point ()
  "Print documentation string of word under point in minibuffer."
  (interactive)
  (message (pf-help-word (pf-word-at-point))))



  

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

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


;; MODES

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


(defconst pf-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 pf-syntax-table (make-syntax-table))

(defun pf-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 )

  )

(pf-init-syntax-table pf-syntax-table)




(defun pf-mode-shared ()
  (interactive) ;; debug


  ;; syntax table
  (set-syntax-table pf-syntax-table)

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

  ;; completion
  (make-local-variable 'comint-dynamic-complete-functions)
  (setq comint-dynamic-complete-functions
	'(pf-tab
	  pf-complete-filename
	  pf-complete-symbol))

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


;; interactive mode  
(define-derived-mode pf-interactive-mode comint-mode "PF-interaction"
  "Packet Forth interaction mode"

  ;; shared stuff
  (pf-mode-shared)

  (use-local-map pf-interactive-mode-map)


)

  

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

  ;; shared stuff
  (pf-mode-shared)

  ;; keymap
  (use-local-map pf-mode-map)
)
  
;; keymaps

;; don't really need tab in interactive mode, so map to complete


(define-key pf-interactive-mode-map "\t" 'comint-dynamic-complete)
(define-key pf-interactive-mode-map "\M-\t" 'pf-complete-symbol)
(define-key pf-interactive-mode-map "\C-c\C-h" 'pf-help-word-at-point)
(define-key pf-interactive-mode-map "\C-m" 'pf-enter)

;; keymap
;(defvar pf-mode-map (make-sparse-keymap))
(set-keymap-parent pf-mode-map text-mode-map)

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








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



(provide 'pf)


;; TESTING

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