;;; cfm.el --- Displays the current function or method on the mode-line

;; Copyright (C) 2006-2011 Davin Pearson

;; Author/Maintainer: m4_davin_pearson
;; Keywords: Current Function method C++, Lisp++, Lisp, C, Java
;; Version: 1.0

;;; Commentary:

;; This file is not part of GNU Emacs.

;; This code causes the current function Elisp/C/C++ or method
;; (Java/C++) to be shown in the mode line.

;;; m4_limitation_of_warranty

;;; m4_install_instructions(cfm)

;;; Known Bugs:

;; None so far!

;;; Code:

(require 'diagnose)

;;(global-set-key [kp-enter] 'cfm--announce)
;;(global-set-key [(shift return)]   'cfm--announce)
;;(global-set-key [(meta return)]    'cfm--announce)

;;(global-set-key [(control return)] nil)
;;(global-set-key [(shift return)]   nil)
;;(global-set-key [(meta return)]    nil))

;;(make-local-variable 'cfm--class::method)
(make-variable-buffer-local 'cfm--class::method)

;; NOTE: this works in lisp-pretty-print.exe
;;(d-quote ?* ?+ ?a ? ?\ ?\n)

;;; (aref "abc" 0)
;;; (setq cfm--class::method " Foo::bar")
;;; (setq cfm--class::method nil)
(defun cfm--announce ()
  (interactive)
  (cfm--set)
  (cond
   ((not cfm--class::method)
    (message "Class::method = nil"))
   ((eq (aref cfm--class::method 0) ? )
    (message "Class::method =%s" cfm--class::method))
   (t
    (message "Class::method = %s" cfm--class::method)))
  ;;(redraw-frame (car (frame-list)))
  )

;;;
;;; FIXME: get current method name......
;;;
;;; BUGGER: errors don't get announced by idle timer
;;;

(progn
  (kill-local-variable 'cfm--new)
  (setq-default cfm--new "")
  )

(defun cfm--outer-get-namespace::class::method ()
  (let* ((namespace (cfm--get-namespace))
         (class     (cfm--get-class (if namespace 1 0)))
         (result    nil))
    (if class
        (let ((method (or (car (cfm--get-method (if namespace 2 1))) "<No Method>")))
          ;;(debug "Roger Ramjet")
          (setq result (concat (if namespace (concat namespace "::") "") class "::" method)))
      ;;(debug "Amber Dempsey")
      (setq result (concat "::" (if namespace (concat namespace "::") "")
                           (cfm--get-class::method (if namespace 1 0)))))
    result
    ))

(defun cfm--set ()
  (interactive)
  (setq d-message-on t)
  ;;(message-and-sit "beg of cfm--set")
  ;;(setq d-message-on nil)
  (save-match-data
    (save-excursion
      (cond
       ((or (eq major-mode 'c-mode)
            (eq major-mode 'c++-mode)
            (eq major-mode 'java-mode))
        (if (and (boundp 'lisp++) lisp++)
            (let ((class (cfm--get-lisp++-class)))
              (if class
                  (let ((method (or (cfm--get-lisp++-method) "<No Method>")))
                    (setq cfm--class::method (concat " " class "::" method)))
                (setq cfm--class::method (concat " ::" (cfm--get-lisp++-function))))
              (force-mode-line-update) ;;; better than updating the entire frame...
              )
          (setq cfm--class::method (concat " " (cfm--outer-get-namespace::class::method)))
          (force-mode-line-update) ;;; better than updating the entire frame...
          ))
       ((eq major-mode 'emacs-lisp-mode)
        ;;(message-and-sit "elm1")
        (setq cfm--class::method (concat " " (cfm--get-defun)))
        (force-mode-line-update)
        ;;(message-and-sit "elm2")
        )
       ((eq major-mode 'php-mode)
        (setq cfm--class::method (concat " " (car (cfm--get-php-function))))
        (force-mode-line-update))
       ((eq major-mode 'compilation-mode)
        (setq cfm--class::method (concat " " (cfm--get-compilation-strobe)))
        (force-mode-line-update))
       (t
        (setq cfm--class::method nil)))
      ))
  (setq d-message-on t)
  ;;(message-and-sit "end of cfm--set")
  )

(defun cfm--get-defun ()
  ;;(message "foo")
  (save-excursion
    ;;(debug)
    (let ((p (point)) (r nil) (function nil) str)
      (setq str "^(\\(defun\\|defmacro\\|defadvice\\) +\\([-a-zA-Z0-9_+<>/=:!]+\\)[ \t]*\\(([^()]*)\\)")
      (cond
       ((save-excursion
          (beginning-of-line)
          (looking-at str))
        (setq function (buffer-substring-no-properties (match-beginning 2) (match-end 2)))
        function)
       ((re-search-backward str nil t)
        (setq function (buffer-substring-no-properties (match-beginning 2) (match-end 2)))
        (if (not (looking-at "("))
            (re-search-backward "(" nil t))
        (condition-case err
            (forward-sexp 1)
          (error nil))
        ;;(when (> (point) p)
        ;;(setq r (concat " " function))
        ;;(set-text-properties 0 (length r) 'bg:yellow r)
        function)))))

(defvar cfm--is-on t
  "Set this variable to nil to disable the display of the current
function/method in the mode line.  This can be useful if
d-speedbar has been activated.")

(when cfm--is-on
  (setq cfm--timer-1 (run-with-idle-timer 2.0 t 'cfm--set))
  ;;(setq cfm--timer-2 (run-with-idle-timer 1.0 t 'cfm--smeg))
  )

(defun cfm--cancel-timers ()
  (cancel-timer cfm--timer-1)
  (cancel-timer cfm--timer-2)
  )

(defun cfm--inside (orig)
  (save-excursion
    (skip-chars-forward " \t")
    (assert (looking-at "{"))
    (condition-case nil
        (forward-sexp 1)
      (error nil))
    (> (point) orig)))

(defun cfm--get-namespace ()
  (let (namespace p)
    (save-excursion
      (setq p (point))
      (when (re-search-backward "^namespace \\([a-zA-Z0-9_]*\\)" nil t)
        (setq namespace (buffer-substring-no-properties
                         (match-beginning 1)
                         (match-end 1)))
        (forward-line 1)
        (beginning-of-line)
        (skip-chars-forward " \t")
        (when (looking-at "{")
          (condition-case nil
              (forward-sexp)
            (error nil))
          (if (> (point) p)
              namespace))))))

;; (cfm--get-class 0)
(defun cfm--get-class (i)
  (let ((case-fold-search nil)
        (orig             nil)
        (class            nil))
    (save-excursion
      (setq orig (point))
      (if (not (re-search-backward (concat "^"
                                           (make-string (* i c-basic-offset) ? )
                                           "\\([A-Za-z]+[ \t]+\\)*\\(class\\|interface\\)[ \t]") nil t))
          nil
        (assert (re-search-forward "\\<\\(class\\|interface\\)\\>" (point-at-eol) t))
        (skip-chars-forward " \t")
        (setq class (buffer-substring-no-properties (point) (save-excursion
                                                              (skip-chars-forward "-A-Za-z0-9_")
                                                              (point))))

        ;;(error "smeg")
        (beginning-of-line)
        (forward-line 1)
        (skip-chars-forward " \t")
        (if (and (looking-at "{") (cfm--inside orig))
            class)))))

(defun cfm--get-lisp++-class ()
  (save-excursion
    (let (class p)
      (setq p (point))
      (when (re-search-backward "^(cclass \\([a-zA-Z0-9_]*\\)" nil t)
        (setq class (buffer-substring-no-properties
                     (match-beginning 1)
                     (match-end 1)))
        (beginning-of-line)
        (forward-sexp 1)
        (if (> (point) p) class)))))

;;(cname foo)
(defun cfm--get-lisp++-method ()
  (save-excursion
    (let (method p)
      (setq p (point))
      (when (re-search-backward (concat "^ (\\(cmethod\\|"
                                        "c-static-method\\|"
                                        "c-constructor-method\\|"
                                        "c-destructor-method\\|"
                                        "cfriend\\)") nil t)
        (when (re-search-forward "(cname \\(~?[a-zA-Z0-9_]+\\))"
                                 (point-at-eol) t)
          (setq method (buffer-substring-no-properties
                        (match-beginning 1)
                        (match-end 1)))
          (beginning-of-line)
          (forward-sexp 1)
          (if (> (point) p) method))))))

(defun cfm--get-lisp++-function ()
  (save-excursion
    (let (name p)
      (setq p (point))
      (when (re-search-backward "^(cfunction" nil t)
        (when (re-search-forward "(cname \\([a-zA-Z0-9_]+\\))"
                                 (point-at-eol) t)
          (setq name (buffer-substring-no-properties
                      (match-beginning 1)
                      (match-end 1)))
          (beginning-of-line)
          (forward-sexp 1)
          (if (> (point) p) name))))))


(defun cfm--get-jtw-decl ()
  (let (p p1 p2 decl1 name1 decl2 name2 decl name str1 str2)
    (save-excursion
      (setq decl "sexy")
      (setq name "eyes")
      (setq str1 (concat "^[ \t]*\\(public +\\|private +\\|protected +\\|\\)\\(abstract +\\|final +\\)*"
                         "\\(function\\|property\\|method\\|classVar\\)"
                         "[ \t]+[A-Za-z][a-zA-Z0-9]+"
                         "[ \t]+\\([a-z][a-zA-Z0-9_]*\\)[ \t]*[()=;]"))
      (setq str2 (concat "^[ \t]*\\(public +\\|private +\\|protected +\\)\\(constructor\\)"
                         "[ \t]+\\([A-Z][a-zA-Z0-9_]*\\)("))
      (beginning-of-line)
      (setq p (point))
      (setq p1 (or (if (looking-at str1) (point))
                   (re-search-backward str1 nil t)))
      (when p1
        (setq decl1 (buffer-substring-no-properties (match-beginning 3) (match-end 3)))
        (setq name1 (buffer-substring-no-properties (match-beginning 4) (match-end 4))))
      (goto-char p)
      (setq p2 (or (if (looking-at str2) (point))
                   (re-search-backward str2 nil t)))
      (when p2
        (setq decl2 (buffer-substring-no-properties (match-beginning 2) (match-end 2)))
        (setq name2 (buffer-substring-no-properties (match-beginning 3) (match-end 3))))
      ;;(if (and (not p1) (not p2) debug-on-error) (debug "both null"))
      (when (or p1 p2)
        ;;(if debug-on-error (debug "A good heart these days is hard to find"))
        (when (not p1)
          (setq p1 (point-min)))
        (when (not p2)
          (setq p2 (point-min)))
        (if (< p1 p2)
            (progn
              (setq decl decl2)
              (setq name name2))
          (progn
            (setq decl decl1)
            (setq name name1))))
      )
    (d-quote message "p=%s, p1=%s, p2=%s, decl1=%s, name1=%s, decl2=%s, name2=%s, decl=%s, name=%s"
             p p1 p2
             decl1 name1
             decl2 name2
             decl  name)
    ;;(sit-for 5)
    (cons decl name)
    ))

(defun cfm--get-jtw-class-or-interface ()
  (save-excursion
    (let (class-or-interface name str)
      (setq str "\\<\\(class\\|interface\\)[ \t]+\\([A-Z][a-zA-Z0-9_]*\\)")
      (when (or (looking-at str)
                (re-search-backward str nil t))
        (setq class-or-interface (buffer-substring-no-properties (match-beginning 1) (match-end 1)))
        (setq name               (buffer-substring-no-properties (match-beginning 2) (match-end 2)))
        (list nil name class-or-interface)))))

;;; (setq i 1)
;;; (setq was-abstract-method nil)
;;; (cfm--get-method 0)
(defun cfm--get-method (i)
  "Gets current method in current buffer"
  (let ((case-fold-search    nil)
        (orig                nil)
        (bra                 nil)
        (end                 nil)
        (done                nil)
        (p1                  nil)
        (p2                  nil)
        (p3                  nil)
        (p4                  nil)
        (name                nil)
        (args                nil)
        (str                 nil)
        (result              nil)
        (was-abstract-method nil)
        (was-all-on-one-line nil)
        (spaces              (make-string (* i c-basic-offset) ? ))
        )
    (save-match-data
      (save-excursion
        (cond
         ((save-excursion
            (beginning-of-line)
            (re-search-forward (concat "^" (make-string (* c-basic-offset i) ? ) "[a-zA-Z_].*;[ \t]*$")
                               (point-at-eol) t))
          (setq was-abstract-method t)
          ;;(message "was-abstract-method")
          )
;;; search for all on one line
         ((save-excursion
            (beginning-of-line) ;;;         1                                              2                                                                          3                             4                   5
            (looking-at (concat "^" spaces "\\(public +\\|private +\\|protected +\\)*[ \t]*\\(boolean\\|char\\|int\\|float\\|double\\|[A-Z][a-zA-Z0-9_]*\\)[][]*[ \t]*\\([a-z][a-zA-Z0-9_]*\\)[ \t]*\\(([^()]*)\\)[ \t]*\\({.*}[ \t]*$\\)")))
          (beginning-of-line)
          (setq was-all-on-one-line t))

;;; search for (concat "^" spaces "}[ \t]*$")
         ((and (save-excursion
                 (beginning-of-line)
                 (looking-at (concat "^" spaces  "}[ \t]*$")))
               (save-excursion
                 (beginning-of-line)
                 (re-search-forward "}" (point-at-eol) t))
               (save-excursion
                 (beginning-of-line)
                 (re-search-forward "}" (point-at-eol) t)
                 (forward-sexp -1)
                 (re-search-backward (concat "^" spaces "{") nil t)))
          ;;(d-beeps "function is above this point")
          (beginning-of-line)
          (re-search-forward "}" (point-at-eol) t)
          (re-search-backward (concat "^" spaces "{[ \t]*$") nil t)
          (beginning-of-line)
          ;;(debug "devil worship")
          )

;;; prototype line
         ((save-excursion
            (forward-line 1)
            (beginning-of-line)
            (looking-at (concat "^" spaces "{")))
          (forward-line 1)
          (beginning-of-line)
          ;;(debug "123")
          )

;;; search for next to prototype line
         ((save-excursion
            (beginning-of-line)
            (looking-at (concat "^" spaces "{")))
          (beginning-of-line))

;;; search up for first open squiggly
         ((re-search-backward (concat "^" spaces "{") nil t)
          ;;(debug "Ten pin bowls")
          (beginning-of-line))

;;; search down for first open squiggly
         ((re-search-forward (concat "^" spaces "{") nil t)
          (beginning-of-line)
          ;;(debug "vampire")
          )
         )
        ;;(debug "Knife")
        ;; ---------------------------------------------------------------
        (cond
         (was-abstract-method
          (when (re-search-forward "(" (point-at-eol) t)
            (forward-char -1)
            (setq p1 (point))
            (forward-sexp 1)
            (setq p2 (point))
            (setq args (buffer-substring-no-properties p1 p2))
            ;;(debug "hollow")
            (goto-char p1)
            (skip-chars-backward " \t")
            (setq p3 (point))
            (skip-chars-backward "A-Za-z0-9_")
            (setq p4 (point))
            (setq name (buffer-substring-no-properties p4 p3))
            (beginning-of-line)
            ;;(debug "Calamansi")
            (list name args)))

         (was-all-on-one-line
          (setq name (buffer-substring-no-properties (match-beginning 3) (match-end 3)))
          (setq args (buffer-substring-no-properties (match-beginning 4) (match-end 4)))
          (setq result (list (d-trim-string name) args)))

         (t
          (beginning-of-line)
          (setq orig (point))
          (if (not (looking-at (concat "^"
                                       (make-string (* i c-basic-offset) ? )
                                       "{")))
              nil
            ;;(debug "Times Square")
            (beginning-of-line)
            (skip-chars-forward " \t")
            (setq bra (point))
            (assert (looking-at "{"))
            ;;(debug "rocketman")
            (when (cfm--inside orig)
              ;;(debug "salami")
              (beginning-of-line)
              (forward-line -1)
              (if (not (search-forward "(" bra t))
                  nil ;;(debug "sardines")
                ;;(debug "hot tomales")
                (forward-char -1)
                (setq end (point))
                (if (search-backward "operator" (point-at-bol) t)
                    (skip-chars-backward "a-zA-Z0-9_") ;; skip over operator
                  (search-forward "(")
                  (save-excursion
                    (forward-char -1)
                    (forward-sexp 1)
                    (setq p2 (point))
                    ;;(debug 123)
                    (setq args (buffer-substring-no-properties end p2)))
                  (forward-char -1)
                  (skip-chars-backward "a-zA-Z0-9_:"))
                (setq name (buffer-substring-no-properties (point) end))
                (setq result (list (d-trim-string name) args))
                result
                )
              )
            )
          )
         )
        )
      )
    )
  )

(defun cfm--get-cfunction ()
  (let ((str    "^(cfunction (cret [a-zA-Z0-9_]+[&*]*) (cname \\([a-zA-Z0-9_]+\\)")
        (result nil))
    (save-excursion
      (beginning-of-line)
      (if (or (looking-at str)
              (re-search-backward str nil t))
          (setq result (buffer-substring-no-properties (match-beginning 1) (match-end 1))))
      result)))

;; (setq i 1)
(defun cfm--get-class::method (i)
  (let ((case-fold-search nil)
        (bra              nil)
        (orig             (point))
        (end              nil)
        )
    (save-match-data
      (save-excursion
        (when (and (re-search-backward (concat "^"
                                               (make-string
                                                (* i c-basic-offset) ? )
                                               "{")
                                       nil
                                       t) (cfm--inside orig))

          (setq bra (point))
          (skip-chars-forward " \t")
          (assert (looking-at "{"))
          (forward-line -1)
          ;;(while (looking-at "^[ \t]+") (forward-line -1))
          ;;(if (looking-at "^STAR_OK") (re-search-forward "(" nil t))
          (when (re-search-forward "(" bra t)
            (forward-char -1)
            (setq end (point))
            (skip-chars-backward "_a-zA-Z0-9")
            (if (d-delta-looking-at "~" -1)
                (forward-char -1))
            (if (d-delta-looking-at "::" -2)
                (progn
                  (forward-char -2)
                  (skip-chars-backward "_a-zA-Z0-9")
                  ;;(d-foo)
                  (buffer-substring-no-properties (point) end))
              ;;(d-foo)
              (buffer-substring-no-properties (point) end))))))))

(defun cfm--get-php-function ()
  (save-excursion
    (save-match-data
      (let (name)
        (when (or (save-excursion
                    (beginning-of-line)
                    (looking-at "^[ \t]*function \\([a-zA-Z_][a-zA-Z0-9_]*\\)[ \t]*\\(([^()]*)\\)"))
                  (re-search-backward "^[ \t]*function \\([a-zA-Z_][a-zA-Z0-9_]*\\)[ \t]*\\(([^()]*)\\)" nil t))
          (setq name (buffer-substring-no-properties (match-beginning 1) (match-end 1)))
          (setq args (buffer-substring-no-properties (match-beginning 2) (match-end 2)))
          (cons name args))))))

(defun cfm--get-compilation-strobe ()
  (save-excursion
    (save-match-data
      (when (save-excursion
              (forward-line 1)
              (re-search-backward "\\*\\*\\*\\* STROBE=\"[a-zA-Z0-9]*\"" nil t))
        (buffer-substring-no-properties (match-beginning 0) (match-end 0))))))

;;;
;;; last
;;;
;;(setcar (last mode-line-format) 'cfm--class::method)
;;(setcdr (last mode-line-format) (cons "-%-" nil))

;;;
;;; first
;;;
;;(setcar mode-line-format 'cfm--class::method)
;;(setq-default mode-line-format (cons "-" mode-line-format))

;;(setq minor-mode-alist (cons '(t cfm--class::method) minor-mode-alist))
;;(last minor-mode-alist)

;;(setcdr (last minor-mode-alist) (cons '(t cfm--class::method) nil))

(setq minor-mode-alist (cons '(t cfm--class::method) minor-mode-alist))

;;(setq cfm--class::method " Foo::smeg")
;;(setq cfm--class::method " Peek::poke")

(provide 'cfm)
;;; cfm.el ends here

