1 ;;; srecode/srt-mode.el --- Major mode for writing screcode macros
3 ;; Copyright (C) 2005, 2007-2011 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 (define-derived-mode srecode-template-mode fundamental-mode
"SRecorder"
187 "Major-mode for writing SRecode macros."
188 (setq comment-start
";;"
190 (set (make-local-variable 'parse-sexp-ignore-comments
) t
)
191 (set (make-local-variable 'comment-start-skip
)
192 "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
193 (set (make-local-variable 'font-lock-defaults
)
194 '(srecode-font-lock-keywords
195 nil
;; perform string/comment fontification
196 nil
;; keywords are case sensitive.
197 ;; This puts _ & - as a word constituant,
198 ;; simplifying our keywords significantly
199 ((?_ .
"w") (?- .
"w")))))
202 (defalias 'srt-mode
'srecode-template-mode
)
204 ;;; Template Commands
206 (defun srecode-self-insert-complete-end-macro ()
207 "Self insert the current key, then autocomplete the end macro."
209 (call-interactively 'self-insert-command
)
210 (when (and (semantic-current-tag)
211 (semantic-tag-of-class-p (semantic-current-tag) 'function
)
213 (let* ((es (srecode-template-get-escape-start))
214 (ee (srecode-template-get-escape-end))
215 (name (save-excursion
216 (forward-char (- (length es
)))
218 (if (looking-at (regexp-quote es
))
219 (srecode-up-context-get-name (point) t
))))
227 (defun srecode-macro-help ()
228 "Provide help for working with macros in a template."
230 (let* ((root 'srecode-template-inserter
)
231 (chl (aref (class-v root
) class-children
))
232 (ess (srecode-template-get-escape-start))
233 (ees (srecode-template-get-escape-end))
235 (with-output-to-temp-buffer "*SRecode Macros*"
236 (princ "Description of known SRecode Template Macros.")
241 (name (symbol-name C
))
242 (key (when (slot-exists-p C
'key
)
247 (setq chl
(append (aref (class-v C
) class-children
) chl
))
250 (when (eq C
'srecode-template-inserter-section-end
)
253 (when (class-abstract-p C
)
259 (when (slot-exists-p C
'key
)
261 (princ " - Character Key: ")
264 (setq showexample nil
)
265 (cond ((string= key
"\n")
271 (prin1 (format "%c" key
))
274 (princ (documentation-property C
'variable-documentation
))
279 (srecode-inserter-prin-example C ess ees
)
289 ;;; Misc Language Overrides
291 (define-mode-local-override semantic-ia-insert-tag
292 srecode-template-mode
(tag)
293 "Insert the SRecode TAG into the current buffer."
294 (insert (semantic-tag-name tag
)))
297 ;;; Local Context Parsing.
299 (defun srecode-in-macro-p (&optional point
)
300 "Non-nil if POINT is inside a macro bounds.
301 If the ESCAPE_START and END are different sequences,
302 a simple search is used. If ESCAPE_START and END are the same
303 characters, start at the beginning of the line, and find out
305 (let ((tag (semantic-current-tag))
306 (es (regexp-quote (srecode-template-get-escape-start)))
307 (ee (regexp-quote (srecode-template-get-escape-end)))
308 (start (or point
(point)))
310 (when (and tag
(semantic-tag-of-class-p tag
'function
))
314 (while (re-search-forward es start t
2))
315 (if (re-search-forward es start t
)
316 ;; If there is a single, the answer is yes.
318 ;; If there wasn't another, then the answer is no.
321 ;; ES And EE are not the same.
323 (and (re-search-backward es
(semantic-tag-start tag
) t
)
324 (>= (or (re-search-forward ee
(semantic-tag-end tag
) t
)
325 ;; No end match means an incomplete macro.
330 (defun srecode-up-context-get-name (&optional point find-unmatched
)
331 "Move up one context as for `semantic-up-context', and return the name.
332 Moves point to the opening characters of the section macro text.
333 If there is no upper context, return nil.
334 Starts at POINT if provided.
335 If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
337 (when point
(goto-char (point)))
338 (let* ((tag (semantic-current-tag))
339 (es (regexp-quote (srecode-template-get-escape-start)))
340 (start (concat es
"[#<]\\(\\w+\\)"))
344 (when (semantic-tag-of-class-p tag
'function
)
345 (while (and (not res
)
346 (re-search-backward start
(semantic-tag-start tag
) t
))
347 (when (save-excursion
348 (setq name
(match-string 1))
349 (let ((endr (concat es
"/" name
)))
350 (if (re-search-forward endr
(semantic-tag-end tag
) t
)
352 (if (not find-unmatched
)
353 (error "Unmatched Section Template")
354 ;; We found what we want.
358 ;; Restore in no result found.
359 (goto-char (or res orig
))
362 (define-mode-local-override semantic-up-context
363 srecode-template-mode
(&optional point
)
364 "Move up one context in the current code.
365 Moves out one named section."
366 (not (srecode-up-context-get-name point
)))
368 (define-mode-local-override semantic-beginning-of-context
369 srecode-template-mode
(&optional point
)
370 "Move to the beginning of the current context.
371 Moves to the beginning of one named section."
372 (if (semantic-up-context point
)
374 (let ((es (regexp-quote (srecode-template-get-escape-start)))
375 (ee (regexp-quote (srecode-template-get-escape-end))))
376 (re-search-forward es
) ;; move over the start chars.
377 (re-search-forward ee
) ;; Move after the end chars.
380 (define-mode-local-override semantic-end-of-context
381 srecode-template-mode
(&optional point
)
382 "Move to the end of the current context.
383 Moves to the end of one named section."
384 (let ((name (srecode-up-context-get-name point
))
385 (tag (semantic-current-tag))
386 (es (regexp-quote (srecode-template-get-escape-start))))
389 (unless (re-search-forward (concat es
"/" name
) (semantic-tag-end tag
) t
)
390 (error "Section %s has no end" name
))
391 (goto-char (match-beginning 0))
394 (define-mode-local-override semantic-get-local-variables
395 srecode-template-mode
(&optional point
)
396 "Get local variables from an SRecode template."
398 (when point
(goto-char (point)))
399 (let* ((tag (semantic-current-tag))
400 (name (save-excursion
401 (srecode-up-context-get-name (point))))
402 (subdicts (semantic-tag-get-attribute tag
:dictionaries
))
406 (setq global
(cons (semantic-tag-new-variable (car D
) nil
)
409 ;; Lookup any subdictionaries in TAG.
412 (while (and (not res
) subdicts
)
413 ;; Find the subdictionary with the same name. Those variables
414 ;; are now local to this section.
415 (when (string= (car (car subdicts
)) name
)
416 (setq res
(cdr (car subdicts
))))
417 (setq subdicts
(cdr subdicts
)))
418 ;; Pre-pend our global vars.
420 ;; If we aren't in a subsection, just do the global variables
424 (define-mode-local-override semantic-get-local-arguments
425 srecode-template-mode
(&optional point
)
426 "Get local arguments from an SRecode template."
427 (require 'srecode
/insert
)
429 (when point
(goto-char (point)))
430 (let* ((tag (semantic-current-tag))
431 (args (semantic-tag-function-arguments tag
))
432 (argsym (mapcar 'intern args
))
434 ;; Create a temporary dictionary in which the
435 ;; arguments can be resolved so we can extract
437 (dict (srecode-create-dictionary t
))
439 ;; Resolve args into our temp dictionary
440 (srecode-resolve-argument-list argsym dict
)
445 (cons (semantic-tag-new-variable key nil entry
)
447 (oref dict namehash
))
451 (define-mode-local-override semantic-ctxt-current-symbol
452 srecode-template-mode
(&optional point
)
453 "Return the current symbol under POINT.
454 Return nil if point is not on/in a template macro."
455 (let ((macro (srecode-parse-this-macro point
)))
459 (defun srecode-parse-this-macro (&optional point
)
460 "Return the current symbol under POINT.
461 Return nil if point is not on/in a template macro.
462 The first element is the key for the current macro, such as # for a
463 section or ? for an ask variable."
465 (if point
(goto-char point
))
466 (let ((tag (semantic-current-tag))
467 (es (regexp-quote (srecode-template-get-escape-start)))
468 (ee (regexp-quote (srecode-template-get-escape-end)))
473 (when (and tag
(semantic-tag-of-class-p tag
'function
)
474 (srecode-in-macro-p point
)
475 (re-search-backward es
(semantic-tag-start tag
) t
))
476 (setq macrostart
(match-end 0))
477 (goto-char macrostart
)
479 (when (not (re-search-forward ee
(semantic-tag-end tag
) t
))
480 (goto-char start
) ;; Pretend we are ok for completion
481 (set-match-data (list start start
))
484 (if (> start
(point))
485 ;; If our starting point is after the found point, that
486 ;; means we are not inside the macro. Retur nil.
488 ;; We are inside the macro, extract the text so far.
489 (let* ((macroend (match-beginning 0))
490 (raw (buffer-substring-no-properties
491 macrostart macroend
))
492 (STATE (srecode-compile-state "TMP"))
493 (inserter (condition-case nil
494 (srecode-compile-parse-inserter
500 (cons (oref inserter
:object-name
)
501 (if (and (slot-boundp inserter
:secondname
)
502 (oref inserter
:secondname
))
503 (split-string (oref inserter
:secondname
)
506 (key (oref inserter key
)))
511 ;; A complex variable thingy.
512 (cons (format "%c" key
)
518 (define-mode-local-override semantic-analyze-current-context
519 srecode-template-mode
(point)
520 "Provide a Semantic analysis in SRecode template mode."
521 (let* ((context-return nil
)
522 (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
523 (prefix (car prefixandbounds
))
524 (bounds (nth 2 prefixandbounds
))
525 (key (car (srecode-parse-this-macro (point))))
529 (prefix-function nil
)
530 (prefixclass (semantic-ctxt-current-class-list))
531 (globalvar (semantic-find-tags-by-class 'variable
(current-buffer)))
533 (scope (semantic-calculate-scope point
))
536 (oset scope fullscope
(append (oref scope localvar
) globalvar
))
539 ;; First, try to find the variable for the first
540 ;; entry in the prefix list.
541 (setq prefix-var
(semantic-find-first-tag-by-name
542 (car prefix
) (oref scope fullscope
)))
545 ((and (or (not key
) (string= key
"?"))
546 (> (length prefix
) 1))
547 ;; Variables can have lisp function names.
548 (with-mode-local emacs-lisp-mode
549 (let ((fcns (semanticdb-find-tags-by-name (car (last prefix
)))))
550 (setq prefix-function
(car (semanticdb-find-result-nth fcns
0)))
551 (setq argtype
'elispfcn
)))
553 ((or (string= key
"<") (string= key
">"))
554 ;; Includes have second args that is the template name.
555 (if (= (length prefix
) 3)
556 (let ((contexts (semantic-find-tags-by-class
557 'context
(current-buffer))))
559 (or (semantic-find-first-tag-by-name
560 (nth 1 prefix
) contexts
)
561 ;; Calculate from location
564 (srecode-template-current-context))
566 (setq argtype
'template
))
568 ;; Calculate from location
570 (symbol-name (srecode-template-current-context))
572 (setq argtype
'template
)
575 (when (> (length prefix
) 1)
576 (let ((toc (srecode-template-find-templates-of-context
577 (read (semantic-tag-name prefix-context
))))
579 (setq prefix-function
580 (or (semantic-find-first-tag-by-name
581 (car (last prefix
)) toc
)
582 ;; Not in this buffer? Search the master
590 (cond ((= (length prefix
) 3)
591 (list (or prefix-var
(nth 0 prefix
))
592 (or prefix-context
(nth 1 prefix
))
593 (or prefix-function
(nth 2 prefix
))))
594 ((= (length prefix
) 2)
595 (list (or prefix-var
(nth 0 prefix
))
596 (or prefix-function
(nth 1 prefix
))))
597 ((= (length prefix
) 1)
598 (list (or prefix-var
(nth 0 prefix
)))
602 (semantic-analyze-context-functionarg
603 "context-for-srecode"
604 :buffer
(current-buffer)
607 :prefix
(or prefixsym
610 :prefixclass prefixclass
612 ;; Use the functionarg analyzer class so we
613 ;; can save the current key, and the index
614 ;; into the macro part we are completing on.
616 :index
(length prefix
)
617 :argument
(list argtype
)
622 (define-mode-local-override semantic-analyze-possible-completions
623 srecode-template-mode
(context)
624 "Return a list of possible completions based on NONTEXT."
625 (with-current-buffer (oref context buffer
)
626 (let* ((prefix (car (last (oref context
:prefix
))))
627 (prefixstr (cond ((stringp prefix
)
629 ((semantic-tag-p prefix
)
630 (semantic-tag-name prefix
))))
631 ; (completetext (cond ((semantic-tag-p prefix)
632 ; (semantic-tag-name prefix))
635 ; ((stringp (car prefix))
637 (argtype (car (oref context
:argument
)))
640 ;; Depending on what the analyzer is, we have different ways
641 ;; of creating completions.
642 (cond ((eq argtype
'template
)
643 (setq matches
(semantic-find-tags-for-completion
644 prefixstr
(current-buffer)))
645 (setq matches
(semantic-find-tags-by-class
648 ((eq argtype
'elispfcn
)
649 (with-mode-local emacs-lisp-mode
650 (setq matches
(semanticdb-find-tags-for-completion
652 (setq matches
(semantic-find-tags-by-class
657 (let ((scope (oref context scope
)))
659 (semantic-find-tags-for-completion
660 prefixstr
(oref scope fullscope
))))
670 (defun srecode-template-get-mode ()
671 "Get the supported major mode for this template file."
672 (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
673 (when m
(read (semantic-tag-variable-default m
)))))
675 (defun srecode-template-get-escape-start ()
676 "Get the current escape_start characters."
677 (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
679 (if es
(car (semantic-tag-get-attribute es
:default-value
))
682 (defun srecode-template-get-escape-end ()
683 "Get the current escape_end characters."
684 (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
686 (if ee
(car (semantic-tag-get-attribute ee
:default-value
))
689 (defun srecode-template-current-context (&optional point
)
690 "Calculate the context encompassing POINT."
692 (when point
(goto-char (point)))
693 (let ((ct (semantic-current-tag)))
695 (setq ct
(semantic-find-tag-by-overlay-prev)))
697 ;; Loop till we find the context.
698 (while (and ct
(not (semantic-tag-of-class-p ct
'context
)))
699 (setq ct
(semantic-find-tag-by-overlay-prev
700 (semantic-tag-start ct
))))
703 (read (semantic-tag-name ct
))
706 (defun srecode-template-find-templates-of-context (context &optional buffer
)
707 "Find all the templates belonging to a particular CONTEXT.
708 When optional BUFFER is provided, search that buffer."
710 (when buffer
(set-buffer buffer
))
711 (let ((tags (semantic-fetch-available-tags))
716 (when (eq cc context
)
721 (when (semantic-tag-of-class-p T
'context
)
722 (setq cc
(read (semantic-tag-name T
)))
723 (when (eq cc context
)
727 (when (and scan
(semantic-tag-of-class-p T
'function
))
728 (setq ans
(cons T ans
)))
733 (provide 'srecode
/srt-mode
)
735 ;; The autoloads in this file must go into the global loaddefs.el, not
736 ;; the srecode one, so that srecode-template-mode can be called from
740 ;; generated-autoload-load-name: "srecode/srt-mode"
743 ;;; srecode/srt-mode.el ends here