1 ;;; srecode/srt-mode.el --- Major mode for writing screcode macros
3 ;; Copyright (C) 2005, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5 ;; This file is part of GNU Emacs.
7 ;; GNU Emacs is free software: you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation, either version 3 of the License, or
10 ;; (at your option) any later version.
12 ;; GNU Emacs is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22 ;; Originally named srecode-template-mode.el in the CEDET repository.
24 (require 'srecode
/compile
)
25 (require 'srecode
/ctxt
)
26 (require 'srecode
/template
)
29 (require 'semantic
/analyze
)
30 (require 'semantic
/wisent
)
32 (require 'semantic
/find
))
34 (declare-function srecode-create-dictionary
"srecode/dictionary")
35 (declare-function srecode-resolve-argument-list
"srecode/insert")
38 (defvar srecode-template-mode-syntax-table
39 (let ((table (make-syntax-table (standard-syntax-table))))
40 (modify-syntax-entry ?\
; ". 12" table) ;; SEMI, Comment start ;;
41 (modify-syntax-entry ?
\n ">" table
) ;; Comment end
42 (modify-syntax-entry ?$
"." table
) ;; Punctuation
43 (modify-syntax-entry ?
: "." table
) ;; Punctuation
44 (modify-syntax-entry ?
< "." table
) ;; Punctuation
45 (modify-syntax-entry ?
> "." table
) ;; Punctuation
46 (modify-syntax-entry ?
# "." table
) ;; Punctuation
47 (modify-syntax-entry ?
! "." table
) ;; Punctuation
48 (modify-syntax-entry ??
"." table
) ;; Punctuation
49 (modify-syntax-entry ?
\" "\"" table
) ;; String
50 (modify-syntax-entry ?\-
"_" table
) ;; Symbol
51 (modify-syntax-entry ?
\\ "\\" table
) ;; Quote
52 (modify-syntax-entry ?\
` "'" table
) ;; Prefix ` (backquote)
53 (modify-syntax-entry ?
\' "'" table
) ;; Prefix ' (quote)
54 (modify-syntax-entry ?\
, "'" table
) ;; Prefix , (comma)
57 "Syntax table used in semantic recoder macro buffers.")
59 (defface srecode-separator-face
60 '((t (:weight bold
:strike-through t
)))
61 "Face used for decorating separators in srecode template mode."
64 (defvar srecode-font-lock-keywords
67 ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$"
68 (1 font-lock-keyword-face
)
69 (2 font-lock-function-name-face
)
70 (3 font-lock-builtin-face
))
71 ("^\\(sectiondictionary\\)\\s-+\""
72 (1 font-lock-keyword-face
))
74 (1 font-lock-keyword-face
))
75 ;; Variable type setting
76 ("^\\(set\\)\\s-+\\(\\w+\\)\\s-+"
77 (1 font-lock-keyword-face
)
78 (2 font-lock-variable-name-face
))
79 ("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$"
80 (1 font-lock-keyword-face
)
81 (2 font-lock-variable-name-face
))
82 ("\\<\\(macro\\)\\s-+\""
83 (1 font-lock-keyword-face
))
84 ;; Context type setting
85 ("^\\(context\\)\\s-+\\(\\w+\\)"
86 (1 font-lock-keyword-face
)
87 (2 font-lock-builtin-face
))
89 ("^\\(prompt\\)\\s-+\\(\\w+\\)"
90 (1 font-lock-keyword-face
)
91 (2 font-lock-variable-name-face
))
92 ("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
93 (1 font-lock-keyword-face
)
94 (3 font-lock-type-face
))
95 ("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face
))
96 ("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
97 (1 font-lock-keyword-face
)
98 (2 font-lock-type-face
))
101 ("^----\n" 0 'srecode-separator-face
)
104 (srecode-template-mode-macro-escape-match 1 font-lock-string-face
)
106 (srecode-template-mode-font-lock-macro-helper
107 limit
"\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*"))
108 1 font-lock-variable-name-face
)
110 (srecode-template-mode-font-lock-macro-helper
111 limit
"\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*"))
112 1 font-lock-keyword-face
)
114 (srecode-template-mode-font-lock-macro-helper
115 limit
"\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)"))
116 (1 font-lock-keyword-face
)
117 (2 font-lock-builtin-face
)
118 (3 font-lock-type-face
))
120 (srecode-template-mode-font-lock-macro-helper
121 limit
"\\([<>?]?\\w*\\):\\(\\w+\\)"))
122 (1 font-lock-keyword-face
)
123 (2 font-lock-type-face
))
125 (srecode-template-mode-font-lock-macro-helper
126 limit
"!\\([^{}$]*\\)"))
127 1 font-lock-comment-face
)
130 "Keywords for use with srecode macros and font-lock.")
132 (defun srecode-template-mode-font-lock-macro-helper (limit expression
)
133 "Match against escape characters.
134 Don't scan past LIMIT. Match with EXPRESSION."
137 (es (regexp-quote (srecode-template-get-escape-start)))
138 (ee (regexp-quote (srecode-template-get-escape-end)))
139 (regex (concat es expression ee
))
143 (if (re-search-forward regex limit t
)
144 (when (equal (car (srecode-calculate-context)) "code")
145 (setq md
(match-data)
149 ;; (when md (message "Found a match!"))
152 (defun srecode-template-mode-macro-escape-match (limit)
153 "Match against escape characters.
154 Don't scan past LIMIT."
157 (es (regexp-quote (srecode-template-get-escape-start)))
158 (ee (regexp-quote (srecode-template-get-escape-end)))
159 (regex (concat "\\(" es
"\\|" ee
"\\)"))
163 (if (re-search-forward regex limit t
)
164 (when (equal (car (srecode-calculate-context)) "code")
165 (setq md
(match-data)
169 ;;(when md (message "Found a match!"))
172 (defvar srecode-font-lock-macro-keywords nil
173 "Dynamically generated `font-lock' keywords for srecode templates.
174 Once the escape_start, and escape_end sequences are known, then
175 we can tell font lock about them.")
177 (defvar srecode-template-mode-map
178 (let ((km (make-sparse-keymap)))
179 (define-key km
"\C-c\C-c" 'srecode-compile-templates
)
180 (define-key km
"\C-c\C-m" 'srecode-macro-help
)
181 (define-key km
"/" 'srecode-self-insert-complete-end-macro
)
183 "Keymap used in srecode mode.")
186 (defun srecode-template-mode ()
187 "Major-mode for writing SRecode macros."
189 (kill-all-local-variables)
190 (setq major-mode
'srecode-template-mode
194 (set (make-local-variable 'parse-sexp-ignore-comments
) t
)
195 (set (make-local-variable 'comment-start-skip
)
196 "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
197 (set-syntax-table srecode-template-mode-syntax-table
)
198 (use-local-map srecode-template-mode-map
)
199 (set (make-local-variable 'font-lock-defaults
)
200 '(srecode-font-lock-keywords
201 nil
;; perform string/comment fontification
202 nil
;; keywords are case sensitive.
203 ;; This puts _ & - as a word constituant,
204 ;; simplifying our keywords significantly
205 ((?_ .
"w") (?- .
"w"))))
206 (run-hooks 'srecode-template-mode-hook
))
209 (defalias 'srt-mode
'srecode-template-mode
)
211 ;;; Template Commands
213 (defun srecode-self-insert-complete-end-macro ()
214 "Self insert the current key, then autocomplete the end macro."
216 (call-interactively 'self-insert-command
)
217 (when (and (semantic-current-tag)
218 (semantic-tag-of-class-p (semantic-current-tag) 'function
)
220 (let* ((es (srecode-template-get-escape-start))
221 (ee (srecode-template-get-escape-end))
222 (name (save-excursion
223 (forward-char (- (length es
)))
225 (if (looking-at (regexp-quote es
))
226 (srecode-up-context-get-name (point) t
))))
234 (defun srecode-macro-help ()
235 "Provide help for working with macros in a template."
237 (let* ((root 'srecode-template-inserter
)
238 (chl (aref (class-v root
) class-children
))
239 (ess (srecode-template-get-escape-start))
240 (ees (srecode-template-get-escape-end))
242 (with-output-to-temp-buffer "*SRecode Macros*"
243 (princ "Description of known SRecode Template Macros.")
248 (name (symbol-name C
))
249 (key (when (slot-exists-p C
'key
)
254 (setq chl
(append (aref (class-v C
) class-children
) chl
))
257 (when (eq C
'srecode-template-inserter-section-end
)
260 (when (class-abstract-p C
)
266 (when (slot-exists-p C
'key
)
268 (princ " - Character Key: ")
271 (setq showexample nil
)
272 (cond ((string= key
"\n")
278 (prin1 (format "%c" key
))
281 (princ (documentation-property C
'variable-documentation
))
286 (srecode-inserter-prin-example C ess ees
)
296 ;;; Misc Language Overrides
298 (define-mode-local-override semantic-ia-insert-tag
299 srecode-template-mode
(tag)
300 "Insert the SRecode TAG into the current buffer."
301 (insert (semantic-tag-name tag
)))
304 ;;; Local Context Parsing.
306 (defun srecode-in-macro-p (&optional point
)
307 "Non-nil if POINT is inside a macro bounds.
308 If the ESCAPE_START and END are different sequences,
309 a simple search is used. If ESCAPE_START and END are the same
310 characters, start at the beginning of the line, and find out
312 (let ((tag (semantic-current-tag))
313 (es (regexp-quote (srecode-template-get-escape-start)))
314 (ee (regexp-quote (srecode-template-get-escape-end)))
315 (start (or point
(point)))
317 (when (and tag
(semantic-tag-of-class-p tag
'function
))
321 (while (re-search-forward es start t
2))
322 (if (re-search-forward es start t
)
323 ;; If there is a single, the answer is yes.
325 ;; If there wasn't another, then the answer is no.
328 ;; ES And EE are not the same.
330 (and (re-search-backward es
(semantic-tag-start tag
) t
)
331 (>= (or (re-search-forward ee
(semantic-tag-end tag
) t
)
332 ;; No end match means an incomplete macro.
337 (defun srecode-up-context-get-name (&optional point find-unmatched
)
338 "Move up one context as for `semantic-up-context', and return the name.
339 Moves point to the opening characters of the section macro text.
340 If there is no upper context, return nil.
341 Starts at POINT if provided.
342 If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
344 (when point
(goto-char (point)))
345 (let* ((tag (semantic-current-tag))
346 (es (regexp-quote (srecode-template-get-escape-start)))
347 (start (concat es
"[#<]\\(\\w+\\)"))
351 (when (semantic-tag-of-class-p tag
'function
)
352 (while (and (not res
)
353 (re-search-backward start
(semantic-tag-start tag
) t
))
354 (when (save-excursion
355 (setq name
(match-string 1))
356 (let ((endr (concat es
"/" name
)))
357 (if (re-search-forward endr
(semantic-tag-end tag
) t
)
359 (if (not find-unmatched
)
360 (error "Unmatched Section Template")
361 ;; We found what we want.
365 ;; Restore in no result found.
366 (goto-char (or res orig
))
369 (define-mode-local-override semantic-up-context
370 srecode-template-mode
(&optional point
)
371 "Move up one context in the current code.
372 Moves out one named section."
373 (not (srecode-up-context-get-name point
)))
375 (define-mode-local-override semantic-beginning-of-context
376 srecode-template-mode
(&optional point
)
377 "Move to the beginning of the current context.
378 Moves to the beginning of one named section."
379 (if (semantic-up-context point
)
381 (let ((es (regexp-quote (srecode-template-get-escape-start)))
382 (ee (regexp-quote (srecode-template-get-escape-end))))
383 (re-search-forward es
) ;; move over the start chars.
384 (re-search-forward ee
) ;; Move after the end chars.
387 (define-mode-local-override semantic-end-of-context
388 srecode-template-mode
(&optional point
)
389 "Move to the end of the current context.
390 Moves to the end of one named section."
391 (let ((name (srecode-up-context-get-name point
))
392 (tag (semantic-current-tag))
393 (es (regexp-quote (srecode-template-get-escape-start))))
396 (unless (re-search-forward (concat es
"/" name
) (semantic-tag-end tag
) t
)
397 (error "Section %s has no end" name
))
398 (goto-char (match-beginning 0))
401 (define-mode-local-override semantic-get-local-variables
402 srecode-template-mode
(&optional point
)
403 "Get local variables from an SRecode template."
405 (when point
(goto-char (point)))
406 (let* ((tag (semantic-current-tag))
407 (name (save-excursion
408 (srecode-up-context-get-name (point))))
409 (subdicts (semantic-tag-get-attribute tag
:dictionaries
))
413 (setq global
(cons (semantic-tag-new-variable (car D
) nil
)
416 ;; Lookup any subdictionaries in TAG.
419 (while (and (not res
) subdicts
)
420 ;; Find the subdictionary with the same name. Those variables
421 ;; are now local to this section.
422 (when (string= (car (car subdicts
)) name
)
423 (setq res
(cdr (car subdicts
))))
424 (setq subdicts
(cdr subdicts
)))
425 ;; Pre-pend our global vars.
427 ;; If we aren't in a subsection, just do the global variables
431 (define-mode-local-override semantic-get-local-arguments
432 srecode-template-mode
(&optional point
)
433 "Get local arguments from an SRecode template."
434 (require 'srecode
/insert
)
436 (when point
(goto-char (point)))
437 (let* ((tag (semantic-current-tag))
438 (args (semantic-tag-function-arguments tag
))
439 (argsym (mapcar 'intern args
))
441 ;; Create a temporary dictionary in which the
442 ;; arguments can be resolved so we can extract
444 (dict (srecode-create-dictionary t
))
446 ;; Resolve args into our temp dictionary
447 (srecode-resolve-argument-list argsym dict
)
452 (cons (semantic-tag-new-variable key nil entry
)
454 (oref dict namehash
))
458 (define-mode-local-override semantic-ctxt-current-symbol
459 srecode-template-mode
(&optional point
)
460 "Return the current symbol under POINT.
461 Return nil if point is not on/in a template macro."
462 (let ((macro (srecode-parse-this-macro point
)))
466 (defun srecode-parse-this-macro (&optional point
)
467 "Return the current symbol under POINT.
468 Return nil if point is not on/in a template macro.
469 The first element is the key for the current macro, such as # for a
470 section or ? for an ask variable."
472 (if point
(goto-char point
))
473 (let ((tag (semantic-current-tag))
474 (es (regexp-quote (srecode-template-get-escape-start)))
475 (ee (regexp-quote (srecode-template-get-escape-end)))
480 (when (and tag
(semantic-tag-of-class-p tag
'function
)
481 (srecode-in-macro-p point
)
482 (re-search-backward es
(semantic-tag-start tag
) t
))
483 (setq macrostart
(match-end 0))
484 (goto-char macrostart
)
486 (when (not (re-search-forward ee
(semantic-tag-end tag
) t
))
487 (goto-char start
) ;; Pretend we are ok for completion
488 (set-match-data (list start start
))
491 (if (> start
(point))
492 ;; If our starting point is after the found point, that
493 ;; means we are not inside the macro. Retur nil.
495 ;; We are inside the macro, extract the text so far.
496 (let* ((macroend (match-beginning 0))
497 (raw (buffer-substring-no-properties
498 macrostart macroend
))
499 (STATE (srecode-compile-state "TMP"))
500 (inserter (condition-case nil
501 (srecode-compile-parse-inserter
507 (cons (oref inserter
:object-name
)
508 (if (and (slot-boundp inserter
:secondname
)
509 (oref inserter
:secondname
))
510 (split-string (oref inserter
:secondname
)
513 (key (oref inserter key
)))
518 ;; A complex variable thingy.
519 (cons (format "%c" key
)
525 (define-mode-local-override semantic-analyze-current-context
526 srecode-template-mode
(point)
527 "Provide a Semantic analysis in SRecode template mode."
528 (let* ((context-return nil
)
529 (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
530 (prefix (car prefixandbounds
))
531 (bounds (nth 2 prefixandbounds
))
532 (key (car (srecode-parse-this-macro (point))))
536 (prefix-function nil
)
537 (prefixclass (semantic-ctxt-current-class-list))
538 (globalvar (semantic-find-tags-by-class 'variable
(current-buffer)))
540 (scope (semantic-calculate-scope point
))
543 (oset scope fullscope
(append (oref scope localvar
) globalvar
))
546 ;; First, try to find the variable for the first
547 ;; entry in the prefix list.
548 (setq prefix-var
(semantic-find-first-tag-by-name
549 (car prefix
) (oref scope fullscope
)))
552 ((and (or (not key
) (string= key
"?"))
553 (> (length prefix
) 1))
554 ;; Variables can have lisp function names.
555 (with-mode-local emacs-lisp-mode
556 (let ((fcns (semanticdb-find-tags-by-name (car (last prefix
)))))
557 (setq prefix-function
(car (semanticdb-find-result-nth fcns
0)))
558 (setq argtype
'elispfcn
)))
560 ((or (string= key
"<") (string= key
">"))
561 ;; Includes have second args that is the template name.
562 (if (= (length prefix
) 3)
563 (let ((contexts (semantic-find-tags-by-class
564 'context
(current-buffer))))
566 (or (semantic-find-first-tag-by-name
567 (nth 1 prefix
) contexts
)
568 ;; Calculate from location
571 (srecode-template-current-context))
573 (setq argtype
'template
))
575 ;; Calculate from location
577 (symbol-name (srecode-template-current-context))
579 (setq argtype
'template
)
582 (when (> (length prefix
) 1)
583 (let ((toc (srecode-template-find-templates-of-context
584 (read (semantic-tag-name prefix-context
))))
586 (setq prefix-function
587 (or (semantic-find-first-tag-by-name
588 (car (last prefix
)) toc
)
589 ;; Not in this buffer? Search the master
597 (cond ((= (length prefix
) 3)
598 (list (or prefix-var
(nth 0 prefix
))
599 (or prefix-context
(nth 1 prefix
))
600 (or prefix-function
(nth 2 prefix
))))
601 ((= (length prefix
) 2)
602 (list (or prefix-var
(nth 0 prefix
))
603 (or prefix-function
(nth 1 prefix
))))
604 ((= (length prefix
) 1)
605 (list (or prefix-var
(nth 0 prefix
)))
609 (semantic-analyze-context-functionarg
610 "context-for-srecode"
611 :buffer
(current-buffer)
614 :prefix
(or prefixsym
617 :prefixclass prefixclass
619 ;; Use the functionarg analyzer class so we
620 ;; can save the current key, and the index
621 ;; into the macro part we are completing on.
623 :index
(length prefix
)
624 :argument
(list argtype
)
629 (define-mode-local-override semantic-analyze-possible-completions
630 srecode-template-mode
(context)
631 "Return a list of possible completions based on NONTEXT."
632 (with-current-buffer (oref context buffer
)
633 (let* ((prefix (car (last (oref context
:prefix
))))
634 (prefixstr (cond ((stringp prefix
)
636 ((semantic-tag-p prefix
)
637 (semantic-tag-name prefix
))))
638 ; (completetext (cond ((semantic-tag-p prefix)
639 ; (semantic-tag-name prefix))
642 ; ((stringp (car prefix))
644 (argtype (car (oref context
:argument
)))
647 ;; Depending on what the analyzer is, we have different ways
648 ;; of creating completions.
649 (cond ((eq argtype
'template
)
650 (setq matches
(semantic-find-tags-for-completion
651 prefixstr
(current-buffer)))
652 (setq matches
(semantic-find-tags-by-class
655 ((eq argtype
'elispfcn
)
656 (with-mode-local emacs-lisp-mode
657 (setq matches
(semanticdb-find-tags-for-completion
659 (setq matches
(semantic-find-tags-by-class
664 (let ((scope (oref context scope
)))
666 (semantic-find-tags-for-completion
667 prefixstr
(oref scope fullscope
))))
677 (defun srecode-template-get-mode ()
678 "Get the supported major mode for this template file."
679 (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
680 (when m
(read (semantic-tag-variable-default m
)))))
682 (defun srecode-template-get-escape-start ()
683 "Get the current escape_start characters."
684 (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
686 (if es
(car (semantic-tag-get-attribute es
:default-value
))
689 (defun srecode-template-get-escape-end ()
690 "Get the current escape_end characters."
691 (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
693 (if ee
(car (semantic-tag-get-attribute ee
:default-value
))
696 (defun srecode-template-current-context (&optional point
)
697 "Calculate the context encompassing POINT."
699 (when point
(goto-char (point)))
700 (let ((ct (semantic-current-tag)))
702 (setq ct
(semantic-find-tag-by-overlay-prev)))
704 ;; Loop till we find the context.
705 (while (and ct
(not (semantic-tag-of-class-p ct
'context
)))
706 (setq ct
(semantic-find-tag-by-overlay-prev
707 (semantic-tag-start ct
))))
710 (read (semantic-tag-name ct
))
713 (defun srecode-template-find-templates-of-context (context &optional buffer
)
714 "Find all the templates belonging to a particular CONTEXT.
715 When optional BUFFER is provided, search that buffer."
717 (when buffer
(set-buffer buffer
))
718 (let ((tags (semantic-fetch-available-tags))
723 (when (eq cc context
)
728 (when (semantic-tag-of-class-p T
'context
)
729 (setq cc
(read (semantic-tag-name T
)))
730 (when (eq cc context
)
734 (when (and scan
(semantic-tag-of-class-p T
'function
))
735 (setq ans
(cons T ans
)))
740 (provide 'srecode
/srt-mode
)
742 ;; The autoloads in this file must go into the global loaddefs.el, not
743 ;; the srecode one, so that srecode-template-mode can be called from
747 ;; generated-autoload-load-name: "srecode/srt-mode"
750 ;; arch-tag: 9c613c25-d885-417a-8f0d-1824b26b22a5
751 ;;; srecode/srt-mode.el ends here