;;; jtw-mode.el --- A new major mode for editing *.jtw files

;; Copyright (C) 2016 Davin Pearson

;; Maintainer: Davin Pearson <http://davin.50webs.com>
;; Keywords: Java Training Wheels major mode
;; Package: dlisp (Davin's version of elisp)
;; Note: The d- prefix stands for _D_avin's customizations to GNU Emacs

;;; Commentary:

;; This program is not part of GNU Emacs

;; This file provides a new major-mode for editing *.jtw files.

;;; Limitation of Warranty

;; 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 3 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 detail.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs, see the file COPYING.  If not, see:
;;
;; <http://www.gnu.org/licenses/gpl-3.0.txt>.

(require 'cl)

(defvar jtw-mode-syntax-table
  (make-syntax-table java-mode-syntax-table))

(defvar jtw-mode-map
  (make-keymap))

(setq auto-mode-alist (cons '("\\.jtw$" . jtw-mode) auto-mode-alist))

;;(defun message (&rest rest))

(progn
  (make-face           'd-face-cc-digits)
  (make-face-bold      'd-face-cc-digits)
  (set-face-background 'd-face-cc-digits "#fff")
  (set-face-foreground 'd-face-cc-digits "#f0f"))

(add-hook 'font-lock-mode-hook 'd-jtw-font-lock-mode-hook--post 'APPEND)

(defun d-font-lock-add-begin (keywords)
  (if (fboundp 'font-lock-add-keywords)
      (font-lock-add-keywords nil keywords nil)
    (setq font-lock-keywords
          (append
           keywords
           font-lock-keywords))))

(defun d-font-lock-add-end (keywords)
  (if (fboundp 'font-lock-add-keywords)
      (font-lock-add-keywords nil keywords 'end)
    (setq font-lock-keywords
          (append
           font-lock-keywords
           keywords))))

(defun cull-from-list (cull-me list)
  (let (ptr)
    (setq ptr list)
    (while ptr
      (when (equal cull-me (car ptr))
        (setq list (cdr ptr))
        (setq ptr  nil)
        )
      (setq ptr (cdr ptr)))
    list))

(defun d-jtw-font-lock-mode-hook--post ()
  (if (eq major-mode 'jtw-mode)
      (d-font-lock-add-end
      '(
        ("^[ \t]*\\(//.*$\\)" 1 'font-lock-comment-face t)))))

(defun jtw-mode ()
  (interactive)
  (kill-all-local-variables)
  (java-mode)
  (setq major-mode 'jtw-mode)
  (setq mode-name "JTW")
  (set-syntax-table jtw-mode-syntax-table)
  (modify-syntax-entry ?_ "w")
  (use-local-map jtw-mode-map)
  (local-set-key "\t"                'jtw--indent-line)
  ;;(local-set-key "\r"              'jtw--newline)
  (local-set-key "\r"                'd-indent-new-comment-line)
  (local-set-key [(meta control \\)] 'jtw--meta-control-backslash)
  (local-set-key "\C-c\C-c"          'd-cc--comment-region)
  (abbrev-mode 1)
  (setq local-abbrev-table java-mode-abbrev-table)
  (make-local-variable 'font-lock-keywords)
  (font-lock-mode 1)
  (font-lock-fontify-buffer)
  ;;(setq font-lock-keywords nil)
  ;;; NOTE: the following code adds fontification of /** ... */ javadoc comments
  (setq font-lock-keywords (cull-from-list
                             '("\\<\\(@[a-zA-Z0-9]+\\)\\>" (1 c-annotation-face))
                             font-lock-keywords))
  '(setq font-lock-keywords (cull-from-list
                             '("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face)
                             font-lock-keywords))
  '(setq font-lock-keywords (cull-from-list
                             '(t
                               (0 font-lock-keyword-face))
                             font-lock-keywords))
  (kill-local-variable 'global-font-lock-keywords)
  (setq global-font-lock-keywords font-lock-keywords)
  (let (str)
    (with-temp-buffer
      ;;(message "temp buffer-name=%s" (buffer-name (current-buffer)))
      ;;(if (get-buffer "*red*") (kill-buffer "*red*"))
      ;;(setq b (generate-new-buffer "*red*"))
      ;;(set-buffer b)
      (emacs-lisp-mode)
      (kill-local-variable 'global-font-lock-keywords)
      (insert-prin1 '(setq global-font-lock-keywords
                           (append global-font-lock-keywords
                                   '(c-font-lock-complex-decl-prepare
                                     (#[(limit)
                                        sexy-string
                                        [limit javadoc-font-lock-doc-comments c-font-lock-doc-comments "/\\*\\*"]
                                        4]))
                                   )))
      (goto-char (point-min))
      (assert (re-search-forward "\\<sexy-string\\>" nil t))
      ;;(replace-match "\"\302\303	#\207\"" 'FIXEDCASE 'LITERAL)
      (replace-match (format "\"\302\303%c%c#\207\"" 8 ?\t) 'FIXEDCASE 'LITERAL)
      (eval-buffer)
      ))
  (setq font-lock-keywords global-font-lock-keywords)
  '(setq font-lock-keywords
         (append
          font-lock-keywords
          '(c-font-lock-complex-decl-prepare
            (#[(limit)
               "\302\303	#\207"
               [limit javadoc-font-lock-doc-comments c-font-lock-doc-comments "/\\*\\*"]
               4]))))
  ;; NOTE: the following code adds fontication of J.T.W. keywords
  (d-font-lock-add-end
   `(
     (,(concat "\\<\\(assert\\|function\\|var\\|classVar\\|"
               "property\\|method\\|constructor\\|"
               "until\\|then\\|and\\|or\\|include\\)\\>")
      (1 font-lock-keyword-face nil))

     ("\\<\\(begin\\)\\>"                             0 font-lock-keyword-face nil)
     ("\\<\\(end\\)\\>"                               0 font-lock-keyword-face nil)
     ("\\<\\(beginMain\\)\\>"                         0 font-lock-keyword-face nil)
     ("\\<\\(endMain\\)\\>"                           0 font-lock-keyword-face nil)

     ("\\<\\(System.out.print\\(ln\\)?\\)("           1 d-face-cc-global nil)
     ("\\<\\(System.exit\\)("                         1 d-face-cc-global nil)
     ("\\<\\([a-z][A-Za-z0-9]*\\.printStackTrace\\)(" 1 d-face-cc-global nil)
     ("\\<\\(null\\|true\\|false\\)\\>"               1 font-lock-constant-face nil)

     (,(concat "\\<\\(abstract\\|break\\|byte\\|case\\|catch\\|"
               "class\\|const\\|continue\\|default\\|do\\|else\\|elseif\\|"
               "extends\\|final\\|finally\\|for\\|goto\\|if\\|"
               "implements\\|import\\|instanceof\\|interface\\|"
               "native\\|new\\|package\\|private\\|protected\\|"
               "public\\|return\\|static\\|super\\|switch\\|"
               "synchronized\\|this\\|throw\\|throws\\|transient\\|"
               "superfor\\|downto\\|to\\|step\\|"
               "try\\|volatile\\|while\\|null\\)\\>")
      1 font-lock-keyword-face nil)

     ("\\(\\<\\|-\\)\\([0-9]+[.]\\)?[0-9]+\\([eE]-?[0-9]+\\)?"
      0 d-face-cc-digits nil)

     ("\\<function [^ \t]* \\([a-z][A-Za-z0-9_]*\\)"
      1 font-lock-function-name-face nil)
     ("\\<method [^ \t]* \\([a-z][A-Za-z0-9_]*\\)"
      1 font-lock-function-name-face nil)

     ("\\<\\(method\\|function\\) \\([a-z][a-zA-Z0-9_]*\\)("
      2 font-lock-function-name-face nil)

     (,(concat "\\<\\([A-Z]+[a-z][A-Za-z0-9]*\\|[A-Z]\\|boolean\\|"
               "char\\|int\\|long\\|short\\|float\\|double\\)"
               "[][]*[ \t]+\\([a-z][A-Za-z0-9]*\\)")
      (1 font-lock-type-face          nil)
      (2 font-lock-variable-name-face nil))

     ("\\<[A-Z]+[a-z][A-Za-z0-9_]*"   0 font-lock-type-face nil)
     ("\\<[A-Z]\\>"                   0 font-lock-type-face nil)
     (,(concat "\\<\\(void\\|boolean\\|char\\|int\\|long\\|short\\|"
               "float\\|double\\)\\>") 0 font-lock-type-face nil t)

     ("\\<m4_[a-zA-Z0-9]*"            0 d-face-m4 t)
     ("\\(\\<m4_dnl\\>\\)\\([^\r\n]*\\)$"
      (1 d-face-m4-dnl t)
      (2 font-lock-comment-face t))
     ("\\<\\(\\([a-z]+\\.\\)*\\)[A-Z][a-zA-Z0-9_]*" 1 'fg:lightred nil)
     ;;("duck" 0 d-face-m4 t)
     ))
  ;;(message-and-sit 5 "Done jtw-mode")
  ;;(font-lock-mode 1)
  (font-lock-fontify-buffer)
  )

(defun jtw--clamp-point (newpoint)
  (max (point-min) (min (point-max) newpoint)))

(defun jtw--inside-comment-or-string ()
  (save-match-data
    (let ((p (get-char-property (jtw--clamp-point (1- (point))) 'face)))
      (or (eq p 'font-lock-string-face)
          (eq p 'font-lock-comment-face)
          (eq p 'font-lock-doc-face)
          (eq p 'font-lock-doc-string-face)
          (eq p 'd-face-super-comment)
          )))
  )

(defun jtw--count-string (string)
  (save-excursion
    (save-match-data
      (let ((max (point-at-eol))
            (count 0))
        (beginning-of-line)
        (while (re-search-forward string max t)
          (if (not (jtw--inside-comment-or-string))
              (incf count)))
        count))))

(defun jtw--count ()
  (let (r)
    (save-excursion
      (beginning-of-line)
      (setq r (- (+ (jtw--count-string "\\<begin\\>")
                    (jtw--count-string "\\<beginMain\\>")
                    (* 2 (jtw--count-string "("))
                    (* 2 (jtw--count-string "{")))
                 (+ (jtw--count-string "\\<end\\>")
                    (jtw--count-string "\\<endMain\\>")
                    (* 2 (jtw--count-string ")"))
                    (* 2 (jtw--count-string "}")))))
      ;;(message "r=%s" r)
      r)))

(defun jtw--get-indent ()
  (save-excursion
    (beginning-of-line)
    (while (looking-at " ")
      (forward-char))
    (- (point) (point-at-bol))))

(defun jtw--set-indent (should-be)
  (if (>= should-be 0)
      (save-excursion
        (beginning-of-line)
        (assert (looking-at "^[ \t]*"))
        (setq i (- (match-end 0) (match-beginning 0)))
        (when (/= i should-be)
          ;;(d-foo)
          (delete-region (point-at-bol)
                         (save-excursion
                           (beginning-of-line)
                           (skip-chars-forward " ") (point)))
          (beginning-of-line)
          (insert (make-string should-be ? ))))))

(defvar jtw--basic-offset 3)

(defun jtw--line-1 ()
  (interactive)
  ;;(d-foo)
  (save-excursion
    (beginning-of-line)
    ;;(d-foo)
    (cond
     ((= (point) (point-min))
      ;;(d-foo)
      (jtw--set-indent 0))
     ((looking-at "^[a-z ]*\\(class\\|interface\\)\\>")
      (jtw--set-indent 0))
     (t
      (forward-line -1)
      (setq rel (jtw--count))
      (setq i (jtw--get-indent))
      (forward-line 1)
      ;;(if (/= rel 0) (beep))
      ;;(set-buffer-modified-p t))
      (jtw--set-indent (+ i (* rel jtw--basic-offset)))))))

(defun jtw--line-2 ()
  ;;(d-foo)
  (save-excursion
    (when (looking-at "^[ \t]*end")
      (setq i (jtw--get-indent))
      (jtw--set-indent (- i jtw--basic-offset)))))

;;(eval '(setq f 123))
;;(setq func 'jtw--line-1)
;;(eval (cons 'jtw--line-1 nil))

(defun jtw--a (func)
  (save-excursion
    (let (m)
      (setq m (make-marker))
      (forward-line)
      (set-marker m (point))
      (if (not (re-search-backward "^\\([a-z].*\\)?\\(class\\|interface\\)" nil t))
          (goto-char (point-min)))
      ;;(d-foo)
      ;;(goto-char (point-min))
      (while (< (point) (marker-position m))
        (eval (cons func nil))
        (forward-line 1))
      (set-marker m nil))))

(defun jtw--meta-control-backslash ()
  (interactive)
  (let (m)
    (setq m (make-marker))
    (set-marker m (point))
    (if (and (fboundp 'd-movement--unpad-buffer) (d-movement--is-correct-mode))
        (d-movement--unpad-buffer))
    (goto-char (point-min))
    (while (< (point) (point-max))
      (jtw--line-1)
      (forward-line 1))
    (goto-char (point-min))
    (while (< (point) (point-max))
      (jtw--line-2)
      (forward-line 1))
    (if (and (fboundp 'd-movement--pad-buffer) (d-movement--is-correct-mode))
        (d-movement--pad-buffer))
    (goto-char m)
    (set-marker m nil)))

(defun jtw--all ()
  ;;(d-beeps "line1")
  (jtw--a 'jtw--line-1)
  ;;(d-beeps "line2")
  (jtw--a 'jtw--line-2)
  ;;(d-beeps "line3")
  )

(defun jtw--get-indents ()
  (save-excursion
    (let (list)
      (goto-char (point-max))
      (beginning-of-line)
      (setq list nil)
      (while (not (bobp))
        (forward-line -1)
        (beginning-of-line)
        (setq i (jtw--get-indent))
        (setq list (cons i list)))
      list)))

(defun jtw--tab ()
  (interactive)
  ;;(debug)
  (let (m mod)
    (setq m (make-marker))
    (set-marker m (point))
    (setq mod (buffer-modified-p))

    (setq list-1 (jtw--get-indents))

    (if (and (fboundp 'd-movement--unpad-buffer) (d-movement--is-correct-mode))
        (d-movement--unpad-buffer))

    (jtw--all)
    (goto-char m)
    (set-marker m nil)
    (beginning-of-line)
    (skip-syntax-forward " ")
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward "end[ \t]*;" nil t)
        (replace-match "end")))

    ;;(set-buffer-modified-p mod)

    (setq list-2 (jtw--get-indents))

    (if (not mod)
        (save-excursion
          (set-buffer-modified-p nil)
          (setq ptr-1 list-1)
          (setq ptr-2 list-2)
          (while (and ptr-1 ptr-2)
            (if (/= (car ptr-1) (car ptr-2))
                (set-buffer-modified-p mod))
            (setq ptr-1 (cdr ptr-1))
            (setq ptr-2 (cdr ptr-2)))))

    (if (and (fboundp 'd-movement--pad-buffer) (d-movement--is-correct-mode))
        (d-movement--pad-buffer))
    ))

(defun jtw--newline ()
  (interactive)
  (let (c)
    (when (save-excursion (beginning-of-line) (looking-at "^.*//"))
      (setq c t))
    ;;(d-foo)
    (insert "\n")
    (jtw--indent-line)
    (if c (insert "// "))))

(defun jtw--delete-line ()
  (delete-region (point-at-bol) (point-at-eol))
  (if (looking-at "\n")
      (delete-char 1))
  )

(defun jtw--get-current-indentation ()
  (save-excursion
    (beginning-of-line)
    (assert (looking-at "^\\([ \t]*\\)[^ \t\r\n]"))
    (/ (length (buffer-substring-no-properties (match-beginning 1) (match-end 1)))
       c-basic-offset)))

(defun jtw--current-line-as-string ()
  (buffer-substring-no-properties (point-at-bol)
                                  (point-at-eol)))

(defun jtw--get-prev-and-this-line ()
  (beginning-of-line)
  (let (line)
    (list (if (save-excursion
                (beginning-of-line)
                (bobp))
              ""
            (save-excursion
              (forward-line -1)
              (beginning-of-line)
              (while (and (not (bobp)) (looking-at "^[ \t]*$"))
                (forward-line -1)
                (beginning-of-line))
              (setq line (d-what-line))
              ;;(message "*** jtw--current-line-as-string=%s" (jtw--current-line-as-string))
              (jtw--current-line-as-string)))
          (jtw--current-line-as-string)
          line)))

(defun jtw--indent-line ()
  (interactive)
  (font-lock-fontify-buffer)
  (let (pair prev-line this-line i triple)
    (save-match-data
      (save-excursion
        (beginning-of-line)t
        (setq i (if (save-excursion
                      (beginning-of-line)
                      (bobp))
                    0
                  (save-excursion
                    (forward-line -1)
                    (beginning-of-line)
                    (while (and (not (bobp)) (looking-at "^[ \t]*$"))
                      (forward-line -1)
                      (beginning-of-line))
                    (jtw--get-current-indentation)
                    ;;(debug "bar")
                    )))
        (setq triple (jtw--get-prev-and-this-line))
        ;;(debug "John Coltrane")
        (setq prev-line (nth 0 triple))
        (setq this-line (nth 1 triple))
        (setq previous-nontrivial-line (nth 2 triple))
        (if (and (string-match "begin" prev-line)
                 (save-excursion
                   (goto-line previous-nontrivial-line)
                   (or (looking-at "^[ \t]*begin")
                       (re-search-forward "begin" (point-at-eol) t)))
                 (not (memq (cadr (text-properties-at (save-excursion
                                                        (goto-line previous-nontrivial-line)
                                                        (beginning-of-line)
                                                        (re-search-forward "begin" (point-at-eol) t))))
                          '(font-lock-string-face
                            font-lock-comment-face
                            font-lock-doc-face
                            font-lock-doc-string-face
                            d-face-super-comment))))
            (incf i))
        (if (and (string-match "end" this-line)
                 (save-excursion
                   (beginning-of-line)
                   (or (looking-at "^[ \t]*end")
                       (re-search-forward "end" (point-at-eol) t)))
                 (not (memq (cadr (text-properties-at (save-excursion
                                                        (beginning-of-line)
                                                        (re-search-forward "end" (point-at-eol) t))))
                            '(font-lock-string-face
                              font-lock-comment-face
                              font-lock-doc-string-face
                              font-lock-doc-face
                              d-face-super-comment))))
            (decf i))
        (setq i (max 0 i))
        ;;(message "indenting line %d to %d" (d-what-line) i)
        ;;(sit-for 1)
        (beginning-of-line)
        ;;(indent-line-to i)
        (indent-line-to (* c-basic-offset i))
        ;;(debug "Halloway")
        )
      (beginning-of-line)
      (skip-chars-forward " \t")
      ;;(debug "antelope")
    )))

(defun doit ()
  (interactive)
  (find-file "~/dlisp/a.jtw")
  (jtw-mode)
  (message "beg font-lock-fontify-buffer")
  (font-lock-fontify-buffer)
  (message "end font-lock-fontify-buffer")
  (sit-for 10))

;;(message "*** loaded jtw-mode")
(provide 'jtw-mode)

