emacs/lisp/cedet/srecode/srt-mode.el

753 lines
24 KiB
EmacsLisp
Raw Normal View History

;;; srecode/srt-mode.el --- Major mode for writing screcode macros
;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs 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.
;; GNU Emacs 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 details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Originally named srecode-template-mode.el in the CEDET repository.
(require 'srecode/compile)
(require 'srecode/ctxt)
(require 'srecode/template)
(require 'semantic)
(require 'semantic/analyze)
(require 'semantic/wisent)
(eval-when-compile
(require 'semantic/find))
(declare-function srecode-create-dictionary "srecode/dictionary")
(declare-function srecode-resolve-argument-list "srecode/insert")
;;; Code:
(defvar srecode-template-mode-syntax-table
(let ((table (make-syntax-table (standard-syntax-table))))
(modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
(modify-syntax-entry ?\n ">" table) ;; Comment end
(modify-syntax-entry ?$ "." table) ;; Punctuation
(modify-syntax-entry ?: "." table) ;; Punctuation
(modify-syntax-entry ?< "." table) ;; Punctuation
(modify-syntax-entry ?> "." table) ;; Punctuation
(modify-syntax-entry ?# "." table) ;; Punctuation
(modify-syntax-entry ?! "." table) ;; Punctuation
(modify-syntax-entry ?? "." table) ;; Punctuation
(modify-syntax-entry ?\" "\"" table) ;; String
(modify-syntax-entry ?\- "_" table) ;; Symbol
(modify-syntax-entry ?\\ "\\" table) ;; Quote
(modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
(modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
(modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
table)
"Syntax table used in semantic recoder macro buffers.")
(defface srecode-separator-face
'((t (:weight bold :strike-through t)))
"Face used for decorating separators in srecode template mode."
:group 'srecode)
(defvar srecode-font-lock-keywords
'(
;; Template
("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$"
(1 font-lock-keyword-face)
(2 font-lock-function-name-face)
(3 font-lock-builtin-face ))
("^\\(sectiondictionary\\)\\s-+\""
(1 font-lock-keyword-face))
("^\\(bind\\)\\s-+\""
(1 font-lock-keyword-face))
;; Variable type setting
("^\\(set\\)\\s-+\\(\\w+\\)\\s-+"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face))
("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face))
("\\<\\(macro\\)\\s-+\""
(1 font-lock-keyword-face))
;; Context type setting
("^\\(context\\)\\s-+\\(\\w+\\)"
(1 font-lock-keyword-face)
(2 font-lock-builtin-face))
;; Prompting setting
("^\\(prompt\\)\\s-+\\(\\w+\\)"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face))
("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
(1 font-lock-keyword-face)
(3 font-lock-type-face))
("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face))
("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
(1 font-lock-keyword-face)
(2 font-lock-type-face))
;; Macro separators
("^----\n" 0 'srecode-separator-face)
;; Macro Matching
(srecode-template-mode-macro-escape-match 1 font-lock-string-face)
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*"))
1 font-lock-variable-name-face)
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*"))
1 font-lock-keyword-face)
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)"))
(1 font-lock-keyword-face)
(2 font-lock-builtin-face)
(3 font-lock-type-face))
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "\\([<>?]?\\w*\\):\\(\\w+\\)"))
(1 font-lock-keyword-face)
(2 font-lock-type-face))
((lambda (limit)
(srecode-template-mode-font-lock-macro-helper
limit "!\\([^{}$]*\\)"))
1 font-lock-comment-face)
)
"Keywords for use with srecode macros and font-lock.")
(defun srecode-template-mode-font-lock-macro-helper (limit expression)
"Match against escape characters.
Don't scan past LIMIT. Match with EXPRESSION."
(let* ((done nil)
(md nil)
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(regex (concat es expression ee))
)
(while (not done)
(save-match-data
(if (re-search-forward regex limit t)
(when (equal (car (srecode-calculate-context)) "code")
(setq md (match-data)
done t))
(setq done t))))
(set-match-data md)
;; (when md (message "Found a match!"))
(when md t)))
(defun srecode-template-mode-macro-escape-match (limit)
"Match against escape characters.
Don't scan past LIMIT."
(let* ((done nil)
(md nil)
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(regex (concat "\\(" es "\\|" ee "\\)"))
)
(while (not done)
(save-match-data
(if (re-search-forward regex limit t)
(when (equal (car (srecode-calculate-context)) "code")
(setq md (match-data)
done t))
(setq done t))))
(set-match-data md)
;;(when md (message "Found a match!"))
(when md t)))
(defvar srecode-font-lock-macro-keywords nil
"Dynamically generated `font-lock' keywords for srecode templates.
Once the escape_start, and escape_end sequences are known, then
we can tell font lock about them.")
(defvar srecode-template-mode-map
(let ((km (make-sparse-keymap)))
(define-key km "\C-c\C-c" 'srecode-compile-templates)
(define-key km "\C-c\C-m" 'srecode-macro-help)
(define-key km "/" 'srecode-self-insert-complete-end-macro)
km)
"Keymap used in srecode mode.")
;;;###autoload
(defun srecode-template-mode ()
"Major-mode for writing srecode macros."
(interactive)
(kill-all-local-variables)
(setq major-mode 'srecode-template-mode
mode-name "SRecoder"
comment-start ";;"
comment-end "")
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'comment-start-skip)
"\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
(set-syntax-table srecode-template-mode-syntax-table)
(use-local-map srecode-template-mode-map)
(set (make-local-variable 'font-lock-defaults)
'(srecode-font-lock-keywords
nil ;; perform string/comment fontification
nil ;; keywords are case sensitive.
;; This puts _ & - as a word constituant,
;; simplifying our keywords significantly
((?_ . "w") (?- . "w"))))
(run-hooks 'srecode-template-mode-hook))
;;;###autoload
(defalias 'srt-mode 'srecode-template-mode)
;;; Template Commands
;;
(defun srecode-self-insert-complete-end-macro ()
"Self insert the current key, then autocomplete the end macro."
(interactive)
(call-interactively 'self-insert-command)
(when (and (semantic-current-tag)
(semantic-tag-of-class-p (semantic-current-tag) 'function)
)
(let* ((es (srecode-template-get-escape-start))
(ee (srecode-template-get-escape-end))
(name (save-excursion
(forward-char (- (length es)))
(forward-char -1)
(if (looking-at (regexp-quote es))
(srecode-up-context-get-name (point) t))))
)
(when name
(insert name)
(insert ee))))
)
(defun srecode-macro-help ()
2009-10-01 03:08:03 +00:00
"Provide help for working with macros in a template."
(interactive)
(let* ((root 'srecode-template-inserter)
(chl (aref (class-v root) class-children))
(ess (srecode-template-get-escape-start))
(ees (srecode-template-get-escape-end))
)
(with-output-to-temp-buffer "*SRecode Macros*"
(princ "Description of known SRecode Template Macros.")
(terpri)
(terpri)
(while chl
(let* ((C (car chl))
(name (symbol-name C))
(key (when (slot-exists-p C 'key)
(oref C key)))
(showexample t)
)
(setq chl (cdr chl))
(setq chl (append (aref (class-v C) class-children) chl))
(catch 'skip
(when (eq C 'srecode-template-inserter-section-end)
(throw 'skip nil))
(when (class-abstract-p C)
(throw 'skip nil))
(princ "`")
(princ name)
(princ "'")
(when (slot-exists-p C 'key)
(when key
(princ " - Character Key: ")
(if (stringp key)
(progn
(setq showexample nil)
(cond ((string= key "\n")
(princ "\"\\n\"")
)
(t
(prin1 key)
)))
(prin1 (format "%c" key))
)))
(terpri)
(princ (documentation-property C 'variable-documentation))
(terpri)
(when showexample
(princ "Example:")
(terpri)
(srecode-inserter-prin-example C ess ees)
)
(terpri)
) ;; catch
);; let*
))))
;;; Misc Language Overrides
;;
(define-mode-local-override semantic-ia-insert-tag
srecode-template-mode (tag)
"Insert the SRecode TAG into the current buffer."
(insert (semantic-tag-name tag)))
;;; Local Context Parsing.
(defun srecode-in-macro-p (&optional point)
"Non-nil if POINT is inside a macro bounds.
If the ESCAPE_START and END are different sequences,
a simple search is used. If ESCAPE_START and END are the same
2009-10-01 03:08:03 +00:00
characters, start at the beginning of the line, and find out
how many occur."
(let ((tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(start (or point (point)))
)
(when (and tag (semantic-tag-of-class-p tag 'function))
(if (string= es ee)
(save-excursion
(beginning-of-line)
(while (re-search-forward es start t 2))
(if (re-search-forward es start t)
;; If there is a single, the the answer is yes.
t
;; If there wasn't another, then the answer is no.
nil)
)
;; ES And EE are not the same.
(save-excursion
(and (re-search-backward es (semantic-tag-start tag) t)
(>= (or (re-search-forward ee (semantic-tag-end tag) t)
;; No end match means an incomplete macro.
start)
start)))
))))
(defun srecode-up-context-get-name (&optional point find-unmatched)
"Move up one context as for `semantic-up-context', and return the name.
Moves point to the opening characters of the section macro text.
If there is no upper context, return nil.
Starts at POINT if provided.
If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
section."
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start)))
(start (concat es "[#<]\\(\\w+\\)"))
(orig (point))
(name nil)
(res nil))
(when (semantic-tag-of-class-p tag 'function)
(while (and (not res)
(re-search-backward start (semantic-tag-start tag) t))
(when (save-excursion
(setq name (match-string 1))
(let ((endr (concat es "/" name)))
(if (re-search-forward endr (semantic-tag-end tag) t)
(< orig (point))
(if (not find-unmatched)
(error "Unmatched Section Template")
;; We found what we want.
t))))
(setq res (point)))
)
;; Restore in no result found.
(goto-char (or res orig))
name)))
(define-mode-local-override semantic-up-context
srecode-template-mode (&optional point)
"Move up one context in the current code.
Moves out one named section."
(not (srecode-up-context-get-name point)))
(define-mode-local-override semantic-beginning-of-context
srecode-template-mode (&optional point)
"Move to the beginning of the current context.
Moves the the beginning of one named section."
(if (semantic-up-context point)
t
(let ((es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end))))
(re-search-forward es) ;; move over the start chars.
(re-search-forward ee) ;; Move after the end chars.
nil)))
(define-mode-local-override semantic-end-of-context
srecode-template-mode (&optional point)
"Move to the beginning of the current context.
Moves the the beginning of one named section."
(let ((name (srecode-up-context-get-name point))
(tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start))))
(if (not name)
t
(unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t)
(error "Section %s has no end" name))
(goto-char (match-beginning 0))
nil)))
(define-mode-local-override semantic-get-local-variables
srecode-template-mode (&optional point)
"Get local variables from an SRecode template."
(save-excursion
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(name (save-excursion
(srecode-up-context-get-name (point))))
(subdicts (semantic-tag-get-attribute tag :dictionaries))
(global nil)
)
(dolist (D subdicts)
(setq global (cons (semantic-tag-new-variable (car D) nil)
global)))
(if name
;; Lookup any subdictionaries in TAG.
(let ((res nil))
(while (and (not res) subdicts)
;; Find the subdictionary with the same name. Those variables
;; are now local to this section.
(when (string= (car (car subdicts)) name)
(setq res (cdr (car subdicts))))
(setq subdicts (cdr subdicts)))
;; Pre-pend our global vars.
(append global res))
;; If we aren't in a subsection, just do the global variables
global
))))
(define-mode-local-override semantic-get-local-arguments
srecode-template-mode (&optional point)
"Get local arguments from an SRecode template."
(require 'srecode/insert)
(save-excursion
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(args (semantic-tag-function-arguments tag))
(argsym (mapcar 'intern args))
(argvars nil)
;; Create a temporary dictionary in which the
;; arguments can be resolved so we can extract
;; the results.
(dict (srecode-create-dictionary t))
)
;; Resolve args into our temp dictionary
(srecode-resolve-argument-list argsym dict)
(maphash
(lambda (key entry)
(setq argvars
(cons (semantic-tag-new-variable key nil entry)
argvars)))
(oref dict namehash))
argvars)))
(define-mode-local-override semantic-ctxt-current-symbol
srecode-template-mode (&optional point)
"Return the current symbol under POINT.
Return nil if point is not on/in a template macro."
(let ((macro (srecode-parse-this-macro point)))
(cdr macro))
)
(defun srecode-parse-this-macro (&optional point)
"Return the current symbol under POINT.
Return nil if point is not on/in a template macro.
The first element is the key for the current macro, such as # for a
section or ? for an ask variable."
(save-excursion
(if point (goto-char point))
(let ((tag (semantic-current-tag))
(es (regexp-quote (srecode-template-get-escape-start)))
(ee (regexp-quote (srecode-template-get-escape-end)))
(start (point))
(macrostart nil)
(raw nil)
)
(when (and tag (semantic-tag-of-class-p tag 'function)
(srecode-in-macro-p point)
(re-search-backward es (semantic-tag-start tag) t))
(setq macrostart (match-end 0))
(goto-char macrostart)
;; We have a match
(when (not (re-search-forward ee (semantic-tag-end tag) t))
(goto-char start) ;; Pretend we are ok for completion
(set-match-data (list start start))
)
(if (> start (point))
;; If our starting point is after the found point, that
;; means we are not inside the macro. Retur nil.
nil
;; We are inside the macro, extract the text so far.
(let* ((macroend (match-beginning 0))
(raw (buffer-substring-no-properties
macrostart macroend))
(STATE (srecode-compile-state "TMP"))
(inserter (condition-case nil
(srecode-compile-parse-inserter
raw STATE)
(error nil)))
)
(when inserter
(let ((base
(cons (oref inserter :object-name)
(if (and (slot-boundp inserter :secondname)
(oref inserter :secondname))
(split-string (oref inserter :secondname)
":")
nil)))
(key (oref inserter key)))
(cond ((null key)
;; A plain variable
(cons nil base))
(t
;; A complex variable thingy.
(cons (format "%c" key)
base)))))
)
)))
))
(define-mode-local-override semantic-analyze-current-context
srecode-template-mode (point)
"Provide a Semantic analysis in SRecode template mode."
(let* ((context-return nil)
(prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
(prefix (car prefixandbounds))
(bounds (nth 2 prefixandbounds))
(key (car (srecode-parse-this-macro (point))))
(prefixsym nil)
(prefix-var nil)
(prefix-context nil)
(prefix-function nil)
(prefixclass (semantic-ctxt-current-class-list))
(globalvar (semantic-find-tags-by-class 'variable (current-buffer)))
(argtype 'macro)
(scope (semantic-calculate-scope point))
)
(oset scope fullscope (append (oref scope localvar) globalvar))
(when prefix
;; First, try to find the variable for the first
;; entry in the prefix list.
(setq prefix-var (semantic-find-first-tag-by-name
(car prefix) (oref scope fullscope)))
(cond
((and (or (not key) (string= key "?"))
(> (length prefix) 1))
;; Variables can have lisp function names.
(with-mode-local emacs-lisp-mode
(let ((fcns (semanticdb-find-tags-by-name (car (last prefix)))))
(setq prefix-function (car (semanticdb-find-result-nth fcns 0)))
(setq argtype 'elispfcn)))
)
((or (string= key "<") (string= key ">"))
;; Includes have second args that is the template name.
(if (= (length prefix) 3)
(let ((contexts (semantic-find-tags-by-class
'context (current-buffer))))
(setq prefix-context
(or (semantic-find-first-tag-by-name
(nth 1 prefix) contexts)
;; Calculate from location
(semantic-tag
(symbol-name
(srecode-template-current-context))
'context)))
(setq argtype 'template))
(setq prefix-context
;; Calculate from location
(semantic-tag
(symbol-name (srecode-template-current-context))
'context))
(setq argtype 'template)
)
;; The last one?
(when (> (length prefix) 1)
(let ((toc (srecode-template-find-templates-of-context
(read (semantic-tag-name prefix-context))))
)
(setq prefix-function
(or (semantic-find-first-tag-by-name
(car (last prefix)) toc)
;; Not in this buffer? Search the master
;; templates list.
nil))
))
)
)
(setq prefixsym
(cond ((= (length prefix) 3)
(list (or prefix-var (nth 0 prefix))
(or prefix-context (nth 1 prefix))
(or prefix-function (nth 2 prefix))))
((= (length prefix) 2)
(list (or prefix-var (nth 0 prefix))
(or prefix-function (nth 1 prefix))))
((= (length prefix) 1)
(list (or prefix-var (nth 0 prefix)))
)))
(setq context-return
(semantic-analyze-context-functionarg
"context-for-srecode"
:buffer (current-buffer)
:scope scope
:bounds bounds
:prefix (or prefixsym
prefix)
:prefixtypes nil
:prefixclass prefixclass
:errors nil
;; Use the functionarg analyzer class so we
;; can save the current key, and the index
;; into the macro part we are completing on.
:function (list key)
:index (length prefix)
:argument (list argtype)
))
context-return)))
(define-mode-local-override semantic-analyze-possible-completions
srecode-template-mode (context)
"Return a list of possible completions based on NONTEXT."
(save-excursion
(set-buffer (oref context buffer))
(let* ((prefix (car (last (oref context :prefix))))
(prefixstr (cond ((stringp prefix)
prefix)
((semantic-tag-p prefix)
(semantic-tag-name prefix))))
; (completetext (cond ((semantic-tag-p prefix)
; (semantic-tag-name prefix))
; ((stringp prefix)
; prefix)
; ((stringp (car prefix))
; (car prefix))))
(argtype (car (oref context :argument)))
(matches nil))
;; Depending on what the analyzer is, we have different ways
;; of creating completions.
(cond ((eq argtype 'template)
(setq matches (semantic-find-tags-for-completion
prefixstr (current-buffer)))
(setq matches (semantic-find-tags-by-class
'function matches))
)
((eq argtype 'elispfcn)
(with-mode-local emacs-lisp-mode
(setq matches (semanticdb-find-tags-for-completion
prefixstr))
(setq matches (semantic-find-tags-by-class
'function matches))
)
)
((eq argtype 'macro)
(let ((scope (oref context scope)))
(setq matches
(semantic-find-tags-for-completion
prefixstr (oref scope fullscope))))
)
)
matches)))
;;; Utils
;;
(defun srecode-template-get-mode ()
"Get the supported major mode for this template file."
(let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
(when m (read (semantic-tag-variable-default m)))))
(defun srecode-template-get-escape-start ()
"Get the current escape_start characters."
(let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
)
(if es (car (semantic-tag-get-attribute es :default-value))
"{{")))
(defun srecode-template-get-escape-end ()
"Get the current escape_end characters."
(let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
)
(if ee (car (semantic-tag-get-attribute ee :default-value))
"}}")))
(defun srecode-template-current-context (&optional point)
"Calculate the context encompassing POINT."
(save-excursion
(when point (goto-char (point)))
(let ((ct (semantic-current-tag)))
(when (not ct)
(setq ct (semantic-find-tag-by-overlay-prev)))
;; Loop till we find the context.
(while (and ct (not (semantic-tag-of-class-p ct 'context)))
(setq ct (semantic-find-tag-by-overlay-prev
(semantic-tag-start ct))))
(if ct
(read (semantic-tag-name ct))
'declaration))))
(defun srecode-template-find-templates-of-context (context &optional buffer)
"Find all the templates belonging to a particular CONTEXT.
When optional BUFFER is provided, search that buffer."
(save-excursion
(when buffer (set-buffer buffer))
(let ((tags (semantic-fetch-available-tags))
(cc 'declaration)
(scan nil)
(ans nil))
(when (eq cc context)
(setq scan t))
(dolist (T tags)
;; Handle contexts
(when (semantic-tag-of-class-p T 'context)
(setq cc (read (semantic-tag-name T)))
(when (eq cc context)
(setq scan t)))
;; Scan
(when (and scan (semantic-tag-of-class-p T 'function))
(setq ans (cons T ans)))
)
(nreverse ans))))
(provide 'srecode/srt-mode)
;; The autoloads in this file must go into the global loaddefs.el, not
;; the srecode one, so that srecode-template-mode can be called from
;; auto-mode-alist.
;; Local variables:
;; generated-autoload-load-name: "srecode/srt-mode"
;; End:
2009-10-02 10:53:34 +00:00
;; arch-tag: 9c613c25-d885-417a-8f0d-1824b26b22a5
;;; srecode/srt-mode.el ends here