;;; delphi-mode-ench.el
(require 'compile)
(require 'cl)

(pushnew '("^\\([-a-zA-Z0-9\\.\\/_~]+\\)(\\([0-9]+\\),\\([0-9]+\\))\s\\([Ff]atal:\\|[Nn]ote:\\|[Ww]arning:\\|[Ee]rror:\\)\s\\(.*$\\)" 1 2 3)
	 compilation-error-regexp-alist)

(setq auto-mode-alist (cons '("\\.pas" . delphi-mode) auto-mode-alist))

(setq delphi-unit-sections
      '(implementation program library package))

(defconst delphi-method-types-regexp
  "\\(procedure\\|function\\|constructor\\|destructor\\)"
  "Regular expression for delphi method types")

(defconst delphi-method-signature-regexp
  ;; like mymethod(myvar1:varType; myvar2:varType=defaultvalue):TReturnType
  (concat
   "\\("
   (concat
    ;; mymethod
    "[_a-zA-Z][_a-zA-Z0-9]*"

    ;; (myvar1:varType; myvar2:varType=defaultvalue)
    "\\((.*)\\)?"

    ;; : TReturnType
    "\\( *: *[_a-zA-Z][_a-zA-Z0-9]*\\)?")
   "\\)")
  "Signature of a delphi method")

(defconst delphi-class-declaration-regexp
  ;;like TMyClass = class(TParentClass)
  "\\(?:^\\|[ \t]\\)[ \t]*\\([_a-zA-Z][_a-zA-Z0-9]*\\) *= *class"
  "Class declaration regexp")

(defvar imenu--function-name-regexp-delphi
  (concat
   "^[ \t]*\\(function\\|procedure\\|constructor\\|destructor\\)[ \t]+"
   "\\([_a-zA-Z][_a-zA-Z0-9]*\\.\\)?"
   "\\([_a-zA-Z][_a-zA-Z0-9]*\\)")
  "Re to get function/procedure names in Delphi.")

(defun delphi-get-classes ()
  (save-excursion
    (goto-char (point-min))

    (let ((classes '()))
      (while (re-search-forward delphi-class-declaration-regexp nil t)
	(push (match-string-no-properties 1) classes))
      classes)))

(defun delphi-in-string (&optional pos)
  (delphi-is (delphi-token-kind (delphi-token-at (point))) delphi-strings))

(defun delphi-in-comment (&optional pos)
  (delphi-is (delphi-token-kind (delphi-token-at (point))) delphi-comments))

(defun delphi-is-definition (&optional pos)
  (let ((class (save-excursion (delphi-in-class-definition))))
  (if class class
    (if pos (goto-char pos))
    (re-search-forward "\\(begin\\|implementation\\)" nil t)
    (let ((match (match-string-no-properties 1)))
      (if (equal match "implementation") 't 'nil)))))

(defun delphi-in-class-definition (&optional pos)
  (if pos (goto-char pos))

  (let ((break 't) (class nil) (open-blocks 0) (max-negative 0))
    (while (and break
		(re-search-backward (concat "\\(?:\\(?:^\\|[^_a-zA-Z0-9]\\)"
					    "\\(end\\|record\\|case\\|begin\\)"
					    "\\(?:$\\|[^_a-zA-Z0-9]\\)"
					    "\\|\\(?:^\\|[ \t]\\)"
					    "\\([_a-zA-Z][_a-zA-Z0-9]*\\)"
					    "[ \t]*=[ \t]*class\\)") nil t))

      (let ((result (match-string-no-properties 1)))
	(if (not (or (delphi-in-string) (delphi-in-comment)))
	    (cond ((equal result "end")
		   (setq open-blocks (+ open-blocks 1)))
		  ((or
		    (or
		     (equal result "record")
		     (equal result "case")) (equal result "begin"))
		   (setq open-blocks (- open-blocks 1))
		   (setq max-negative (min open-blocks max-negative)))

		  ('t  (setq break nil)
		       (if (= open-blocks max-negative)
			   (setq class (match-string-no-properties 2))))))))
    class)
)

(defun imenu--create-delphi-index (&optional regexp)
  (let ((index-alist '())
	(progress-prev-pos 0)
	(case-fold-search t))
    (goto-char (point-min))
    (imenu-progress-message progress-prev-pos 0)
    (save-match-data
      (while (re-search-forward
	      (or regexp imenu--function-name-regexp-delphi)
	      'nil 't)
	(imenu-progress-message progress-prev-pos)
	(let ((pos (save-excursion
		     (beginning-of-line)
		     (if imenu-use-markers (point-marker) (point))))
	      (function-name (match-string-no-properties 3))
	      (class-name (match-string-no-properties 2)))
	  (let ((class-def (save-excursion (delphi-is-definition pos))))
	    (let ((class-name (if class-name (substring class-name 0 -1) class-def))
		  (content (let ((sub-alist (if (not (equal class-def 't))
						 (assoc class-def index-alist)
						 index-alist)))
			     (if (not (equal class-def 'nil))
				 (cond ((assoc "Definition" sub-alist)
					(let ((alist (reverse (assoc "Definition" sub-alist))))
					  (setcdr (assoc "Definition" sub-alist)
						  (cdr (reverse (push (cons function-name pos) alist)))))
					nil)
				       (t
					(list "Definition" (cons function-name pos))))
			     	(cons function-name pos)))))

	      (if content (cond
			   ((not (or (equal class-name 'nil) (equal class-name 't)))
			    (cond ((assoc class-name index-alist)
				   (let ((alist (reverse (assoc class-name index-alist))))
				     (setcdr (assoc class-name index-alist)
					     (cdr (reverse (push content alist))))))
				  (t
				   (push (list class-name content) index-alist))
				  ))
			   (t
			    (push content index-alist))))
	      )))))
      (imenu-progress-message progress-prev-pos 100)
      (setq index-alist (nreverse index-alist))

      ; remove class-name if only one class exists
      (if (equal (length index-alist) 1) (setq index-alist (cdr (car index-alist))))
      index-alist))

(defun delphi-method-jump ()
  (cond ((save-excursion (delphi-is-definition)) (delphi-go-to-method-implementation))
	('t (delphi-go-to-method-definition))))

(defun delphi-go-to-method-definition ()
  "Move cursor to method definition of current edited method"
  (interactive)
  (re-search-backward (concat
		      delphi-method-types-regexp
		      " *"
		      "\\([_a-zA-Z][_a-zA-Z0-9]*\\)\\."
		      delphi-method-signature-regexp))
  (let
      ((class (match-string 2))
       (method (match-string 3)))
    (message "%s %s" class method)
    (re-search-backward (concat class " *= *class"))
    (re-search-forward method)))


(defun delphi-go-to-method-implementation ()
  "Move cursor to method implementation of method on current line"
  (interactive)
  (beginning-of-line)
  (let (methodtype methodname class)
    (re-search-forward (concat
			delphi-method-types-regexp
			" *"
			delphi-method-signature-regexp))
    (setq methodtype (match-string 1)
	  methodname (match-string 2))
    (re-search-backward delphi-class-declaration-regexp)
    (setq class (match-string 1))
    (re-search-forward (concat methodtype " +" class "\\." methodname))))


(defun delphi-complete-method ()
  "Create the method skeleton for method definition under cursor"
  (interactive)
  (beginning-of-line)
  (let (methodtype methodname class)
    (re-search-forward (concat
			delphi-method-types-regexp
			" *"
			delphi-method-signature-regexp))
    (setq methodtype (match-string 1)
	  methoddef (match-string 2))
    (re-search-backward delphi-class-declaration-regexp)
    (setq class (match-string 1))
    (end-of-buffer)
    (re-search-backward (concat
			 "\\("
			 delphi-method-types-regexp
			 " *"
			 class
			 "\\)\\|implementation"))
    (next-line)
    (re-search-forward (concat
			delphi-method-types-regexp
			"\\|\\(initialization\\|finalization\\|end\\.\\)"))
    (previous-line)
    (newline 2)
    (previous-line 2)
    (insert (concat methodtype " " class "." methoddef ";"))
    (newline)
    (insert "begin")
    (newline 2)
    (insert "end;")
    (previous-line)))


;;key binding
(add-hook 'delphi-mode-hook
	  '(lambda ()
	     (define-key delphi-mode-map "\C-c\C-mi" 'delphi-go-to-method-implementation)
	     (define-key delphi-mode-map "\C-c\C-md" 'delphi-go-to-method-definition)
	     (define-key delphi-mode-map "\C-c\C-mc" 'delphi-complete-method)))

; hook if starting delphi-mode
(add-hook 'delphi-mode-hook
	  '(lambda ()
	     (setq comment-start "// ")
	     (require 'imenu)
	     (setq imenu-create-index-function
		   'imenu--create-delphi-index)
	     (imenu-add-menubar-index)))