;;; coloravrforth.el --- minor made for editing avrforth with colors
;;; by Max-Gerd Retzlaff, 2008-08-08

;;; based on:
;;; color-mode.el --- minor mode for colorizing lines of a file
;;; by
;;; Don Knuth, August 2000

;; For now the following colors are defined:
;;
;;   color   description   symbol   key
;;  ------- ------------- -------- -----
;;   red      define          :     C-cr
;;   yellow   execute               C-cy
;;   green    compile         ]     C-cg
;;   cyan     compile macro   c     C-cc
;;   white    comment       (  )    C-cw
;;
;; As whith colorForth the yellow->green transition is special:
;; Yellow words are executed. If a sequence of yellow words is
;; followed by a green words, the sequence of yellow words is
;; expected to leave a single number on the stack. This number
;; will be compiled (as a literal with "l") at the transition.
;; If the yellow words are not followed by a green word, nothing
;; gets compiled.


(defface avrforth-face-red    '((t :foreground "red"))    "define")
(defface avrforth-face-yellow '((t :foreground "yellow")) "execute")
(defface avrforth-face-green  '((t :foreground "green"))  "compile")
(defface avrforth-face-cyan   '((t :foreground "cyan"))   "macro-compile")
(defface avrforth-face-white  '((t :foreground "white"))  "comment")

(defconst avrforth-mode-faces
  '((red    . avrforth-face-red)
    (yellow . avrforth-face-yellow)
    (green  . avrforth-face-green)
    (cyan   . avrforth-face-cyan)
    (white  . avrforth-face-white))
    "Assotiation list of the faces available in avrforth mode.")

(defun avrforth-color-to-face (color)
  (cdr (assq color avrforth-mode-faces)))

(defun avrforth-face-to-color (face)
  (car (rassq face avrforth-mode-faces)))

(defconst avrforth-mode-marks
  '((red    ": ")
    (yellow "")
    (green  "] ")
    (cyan   "c ")
    (white  "( " " )")
    ;; special color changes
    (yellow->green " l")))

(defconst avrforth-mode-marks-regex
  (apply #'concat
         (butlast
          (mapcan (lambda (x)
                    (list x "\\|"))
                  (remove ""
                          (mapcar #'second avrforth-mode-marks))))))

(defun avrforth-color-to-marks (color)
  (cdr (assq color avrforth-mode-marks)))

(defun avrforth-combine-colors (old-color new-color)
  (intern (concat (symbol-name old-color) "->" (symbol-name new-color))))

(defvar avrforth-mode nil
  "True if Color mode is in use.")
(make-variable-buffer-local 'avrforth-mode)
(put 'avrforth-mode 'permanent-local t) ;; preserve color across major mode change
(setq-default avrforth-mode nil)

(defvar avrforth-already-decoded nil
  "True if the buffer is already decoded.")
(make-variable-buffer-local 'avrforth-already-decoded)
(put 'avrforth-already-decoded 'permanent-local t) ;; preserve decoded state across major mode change
(setq-default avrforth-already-decoded nil)

(or (assq 'avrforth-mode minor-mode-alist)
    (setq minor-mode-alist
          (cons '(avrforth-mode " Color") minor-mode-alist)))

(defvar avrforth-mode-map nil
  "Keymap for Color Mode.")

(if (null avrforth-mode-map)
    (fset 'avrforth-mode-map (setq avrforth-mode-map (make-sparse-keymap))))

(if (not (assq 'avrforth-mode minor-mode-map-alist))
    (setq minor-mode-map-alist
          (cons (cons 'avrforth-mode avrforth-mode-map)
                minor-mode-map-alist)))

(define-key avrforth-mode-map "\C-cr" 'avrforth-mode-change-to-red)
(define-key avrforth-mode-map "\C-cy" 'avrforth-mode-change-to-yellow)
(define-key avrforth-mode-map "\C-cg" 'avrforth-mode-change-to-green)
(define-key avrforth-mode-map "\C-cc" 'avrforth-mode-change-to-cyan)
(define-key avrforth-mode-map "\C-cw" 'avrforth-mode-change-to-white)

(defconst avrforth-file-mark
;;  ": avrforth ] ; \n")
  "( avrforth )\n")

(push `(avrforth "avrforth format" ,avrforth-file-mark
                 avrforth-decode avrforth-encode t avrforth-mode)
      format-alist)

(defun avrforth-mode-change-to-red    () (interactive)(avrforth-mode-change-color 'red))
(defun avrforth-mode-change-to-yellow () (interactive)(avrforth-mode-change-color 'yellow))
(defun avrforth-mode-change-to-green  () (interactive)(avrforth-mode-change-color 'green))
(defun avrforth-mode-change-to-cyan   () (interactive)(avrforth-mode-change-color 'cyan))
(defun avrforth-mode-change-to-white  () (interactive)(avrforth-mode-change-color 'white))

;; (old color-mode.el comment) (mgr, 20080809)
;;
;; In color mode the normal stickiness conventions are reversed, because
;; we want to type at the beginning of a colorized line and inherit the
;; color of that line. Similarly, we want to type at the beginning of
;; a non-colorized line without inheriting the color of the newline
;; that ends the previous line. (I want the newline character to be
;; colorized, so that painting always extends to the right margin.)
;; The newline is made rear-nonsticky. All characters of a painted line
;; are made front-sticky; I don't want to do this just to the first character,
;; because the user can delete it.
;;
;; If this mode is going to be used seriously in connection with other modes,
;; I could be more careful to confine the stickiness switching to the
;; text properties I control and not to any other attributes. But the
;; design of Emacs Lisp makes that rather painful, so I simply set
;; front-sticky and rear-nonsticky to `t' in this version of the code.
;; I'll let other people hack more generality into the routine if they
;; think it is worth their time.

(defun looking-between ()
  (looking-at "\n\\| "))

(defun looking-between-or-beginning ()
  (or (looking-between)
      (bobp)
      (save-excursion
        (backward-char)
        (looking-between))))

(defun looking-between-or-end ()
  (or (looking-between)
      (eobp)))

;; (defun avrforth-mode-change-color (color)
;;   "Displays the current LINE using the nth face of avrforth-mode-faces."
;;   (save-excursion
;;     (let (beg end)
;;       (unless (looking-between-or-beginning)
;;         (backward-forthword))
;;       (setq beg (point))
;;       (unless (looking-between-or-end)
;;         (forward-forthword))
;;       (setq end (point))
;;      
;;       (facemenu-add-face (avrforth-color-to-face color) beg end)
;;       ;; (put-text-property beg end 'face (avrforth-color-to-face color))
;;       (put-text-property beg end 'front-sticky t)
;;       (put-text-property (1- end) end 'rear-nonsticky t)
;;       )))

(defun avrforth-mode-change-color (color)
  "Displays the current LINE using the nth face of avrforth-mode-faces."
  (save-excursion
    (let (beg end)
      (unless (looking-between-or-beginning)
        (backward-forthword))
      (setq beg (point))
      (if (eobp) ;; ugly!
          (insert " ")
        (unless (looking-between)
          (forward-forthword)))
      (when (= beg (point))
        (forward-char))
      (setq end (point))

      (put-text-property beg end 'face (avrforth-color-to-face color))
      ;;(put-text-property beg end 'avrforth-mode n)
      (put-text-property beg end 'front-sticky t)
      (put-text-property (1- end) end 'rear-nonsticky t)
      )))

;; change makes a space if right behind a word
(defun avrforth-mode-change-color (color)
  "Displays the current LINE using the nth face of avrforth-mode-faces."
  (let (go-forth)
    (save-excursion
      (let (beg end)
        (unless (or (looking-between-or-beginning)
                    (eobp))
          (backward-forthword))
        (setq beg (point))
        (if (or (looking-between)
                (eobp))
            (if (and (not (bobp))
                     (save-excursion
                       (backward-char)
                       (looking-between)))
                (if (eq color 'red)
                    (progn
                      (delete-backward-char 1)
                      (insert "\n")
                      (decf beg)
                      (setq go-forth t))
                  (decf beg))
              (if (eq color 'red)
                  (insert "\n")
                (insert " "))
              (setq go-forth t))
          (forward-forthword))
        (when (= beg (point))
          (forward-char))
        (setq end (point))

        (put-text-property beg end 'face (avrforth-color-to-face color))
        ;;(put-text-property beg end 'avrforth-mode n)
        (put-text-property beg end 'front-sticky t)
        ;(put-text-property (1- end) end 'rear-nonsticky t)))
        ))
    (when go-forth
      (forward-char))))

(defun avrforth-mode-remove-all-colors ()
  (remove-text-properties (point-min) (point-max) '(face nil)))

(defun avrforth-fix-forth-mode ()
  (setq forth-disable-parser t)
  (setq forth-program-name "picocom -l -b 38400 /dev/ttyUSB0")
  (defun forth-send-region (start end)
    "Send the current region to the inferior Forth process."
    (interactive "r")
    (if avrforth-mode
        (let ((oldbuf (current-buffer)))
          (with-temp-buffer
            (insert-buffer-substring oldbuf start end)
            (format-encode-buffer 'avrforth)
            (comint-send-region (forth-proc) (point-min) (point-max))))
      (comint-send-region (forth-proc) start end))
    (comint-send-string (forth-proc) "\r")))

(defun avrforth-fix-forth-mode ()
  (setq forth-disable-parser t)
  (setq forth-program-name "picocom -l -b 38400 /dev/ttyUSB0")
  (defun forth-send-region (start end)
    "Send the current region to the inferior Forth process."
    (interactive "r")
    (if avrforth-mode
        (let ((oldbuf (current-buffer)))
          (with-temp-buffer
            (insert-buffer-substring oldbuf start end)
            (format-encode-buffer 'avrforth)
            (let ((string (concat (buffer-substring (point-min) (point-max))
                                  "\n")))
              (comint-send-string (forth-proc) (replace-regexp-in-string "\n" "\r" string)))))
      (comint-send-region (forth-proc) start end)
      (comint-send-string (forth-proc) "\r"))))

(defun avrforth-mode (&optional arg)
  "Minor mode for editing colorized files.

\\<avrforth-mode-map>\\{avrforth-mode-map}"
  (interactive "P")
  (let ((mod (buffer-modified-p)))
    (cond ((or (<= (prefix-numeric-value arg) 0)
               (and avrforth-mode (null arg)))
           (setq avrforth-mode nil) ;;; negative arg turns mode off
           (setq buffer-file-format (delq 'avrforth buffer-file-format))
           (when avrforth-already-decoded
             (format-encode-buffer 'avrforth)
             (avrforth-mode-remove-all-colors)))
          (avrforth-mode nil) ;;; if already on, we don't do anything
          (t (setq avrforth-mode t) ;;; otherwise turn it on
             ;; (fundamental-mode) ;; to be sure
             (avrforth-fix-forth-mode)
             (add-to-list 'buffer-file-format 'avrforth)
             (unless avrforth-already-decoded
               (format-decode-buffer 'avrforth))))
    (set-buffer-modified-p mod)
    (force-mode-line-update)))

(defun avrforth-decode (from to)
  (setq avrforth-already-decoded t)
  (let ((save-undos buffer-undo-list))
    (setq buffer-undo-list t)
    (save-restriction
      (narrow-to-region from to)
      (goto-char from)
      (when (looking-at avrforth-file-mark)
        (delete-char (length avrforth-file-mark)))
      (while (not (eobp))
        (let (end-mark-p)
          (unless
              (loop for marks in avrforth-mode-marks
                    for color = (first marks)
                    for start-mark = (second marks)
                    for end-mark = (third marks)
                    unless (equal start-mark "")
                    when (looking-at start-mark)
                    do (progn
                         (delete-char (length start-mark))
                         (skip-whitespace-forward)
                         (avrforth-mode-change-color color)
                         (when end-mark
                           (let ((start (point))
                                 end)
                             (search-forward end-mark)
                             (delete-backward-char (length end-mark))
                             (setq end (point))
                             (put-text-property start end 'face (avrforth-color-to-face color)))
                           (setq end-mark-p t))
                         (return t)))
            (avrforth-mode-change-to-yellow)
            (save-excursion
              (forward-forthword)
              (skip-whitespace-forward)
              (when (looking-at "l ")
                (forward-char 2)
                (skip-whitespace-forward)
                (when (looking-at (first (avrforth-color-to-marks 'green)))
                  (search-backward "l ")
                  (delete-char (length "l "))))))
          (unless end-mark-p
            (forward-forthword))
          (skip-whitespace-forward)))
      (setq buffer-undo-list save-undos)
      (point-max))))

(defun forward-forthword ()
  (interactive)
  (skip-syntax-forward "-")
  (skip-syntax-forward "^-"))

(defun backward-forthword ()
  (interactive)
  (skip-syntax-backward "-")
  (skip-syntax-backward "^-"))

(defun skip-whitespace-forward ()
  (interactive)
  (skip-syntax-forward "-"))

(defun skip-whitespace-backward ()
  (interactive)
  (skip-syntax-backward "-"))

(defun avrforth-encode (from to orig-buf)
  (setq avrforth-already-decoded nil)
  (save-restriction
    (narrow-to-region from to)
    (goto-char from)
    (insert avrforth-file-mark)
    (while (not (eobp))
      (skip-whitespace-forward)
      (let* ((pos (point))
             (color (avrforth-face-to-color (get-text-property pos 'face))))
        (while color
          (let ((marks (avrforth-color-to-marks color)))
            ;; new color -> insert start mark
            (insert (first marks) "")
            ;; color with end mark?
            (if (second marks)
                (progn
                  (setq pos (point))
                  (goto-char (or (next-single-property-change pos 'face)
                                 (point-max)))
                  (save-excursion
                    (skip-whitespace-backward)
                    (insert "" (second marks))))
              ;; color without end mark
              (forward-forthword) (skip-whitespace-forward)))
          (setq pos (point)
                old-color color
                color (avrforth-face-to-color (get-text-property pos 'face)))
          ;; special color change?
          (let ((marks (avrforth-color-to-marks
                        (avrforth-combine-colors old-color color))))
            (when marks
              (save-excursion
                (skip-whitespace-backward)
                (insert "" (first marks))))))
        (goto-char (or (next-single-property-change pos 'face)
                       (point-max)))))
    (point-max)))

;; (defun avrforth-encode (from to orig-buf)
;;     (save-restriction
;;       (narrow-to-region from to)
;;       (goto-char from)
;;       (insert "avrforth\n")
;;       (while (not (eobp))
;;         (skip-whitespace-worward)
;;         (let* ((pos (point))
;;                (color (avrforth-face-to-color (get-text-property pos 'face))))
;;           (while color
;;             (insert (first (avrforth-color-to-marks color)) " ")
;;             (forward-forthword) (skip-whitespace-forward)
;;             (setq pos (point)
;;                   color (avrforth-face-to-color (get-text-property pos 'face))))
;;         (goto-char (or (next-single-property-change pos 'face)
;;                        (point-max)))))
;;     (point-max)))