Nuke arch-tags.
[emacs.git] / lisp / cedet / srecode / dictionary.el
blob30052c0749807f57ff2316f381269402ce7e6beb
1 ;;; srecode-dictionary.el --- Dictionary code for the semantic recoder.
3 ;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22 ;;; Commentary:
24 ;; Dictionaries contain lists of names and their associated values.
25 ;; These dictionaries are used to fill in macros from recoder templates.
27 ;;; Code:
29 ;;; CLASSES
31 (eval-when-compile (require 'cl))
32 (require 'eieio)
33 (require 'srecode)
34 (require 'srecode/table)
35 (eval-when-compile (require 'semantic))
37 (declare-function srecode-compile-parse-inserter "srecode/compile")
38 (declare-function srecode-dump-code-list "srecode/compile")
39 (declare-function srecode-load-tables-for-mode "srecode/find")
40 (declare-function srecode-template-table-in-project-p "srecode/find")
41 (declare-function srecode-insert-code-stream "srecode/insert")
42 (declare-function data-debug-new-buffer "data-debug")
43 (declare-function data-debug-insert-object-slots "eieio-datadebug")
44 (declare-function srecode-field "srecode/fields")
46 (defclass srecode-dictionary ()
47 ((namehash :initarg :namehash
48 :documentation
49 "Hash table containing the names of all the templates.")
50 (buffer :initarg :buffer
51 :documentation
52 "The buffer this dictionary was initialized with.")
53 (parent :initarg :parent
54 :type (or null srecode-dictionary)
55 :documentation
56 "The parent dictionary.
57 Symbols not appearing in this dictionary will be checked against the
58 parent dictionary.")
59 (origin :initarg :origin
60 :type string
61 :documentation
62 "A string representing the origin of this dictionary.
63 Useful only while debugging.")
65 "Dictionary of symbols and what they mean.
66 Dictionaries are used to look up named symbols from
67 templates to decide what to do with those symbols.")
69 (defclass srecode-dictionary-compound-value ()
71 "A compound dictionary value.
72 Values stored in a dictionary must be a STRING,
73 a dictionary for showing sections, or an instance of a subclass
74 of this class.
76 Compound dictionary values derive from this class, and must
77 provide a sequence of method implementations to convert into
78 a string."
79 :abstract t)
81 (defclass srecode-dictionary-compound-variable
82 (srecode-dictionary-compound-value)
83 ((value :initarg :value
84 :documentation
85 "The value of this template variable.
86 Variables in template files are usually a single string
87 which can be inserted into a dictionary directly.
89 Some variables may be more complex and involve dictionary
90 lookups, strings, concatenation, or the like.
92 The format of VALUE is determined by current template
93 formatting rules.")
94 (compiled :initarg :compiled
95 :type list
96 :documentation
97 "The compiled version of VALUE.")
99 "A compound dictionary value for template file variables.
100 You can declare a variable in a template like this:
102 set NAME \"str\" macro \"OTHERNAME\"
104 with appending various parts together in a list.")
106 (defmethod initialize-instance ((this srecode-dictionary-compound-variable)
107 &optional fields)
108 "Initialize the compound variable THIS.
109 Makes sure that :value is compiled."
110 (let ((newfields nil)
111 (state nil))
112 (while fields
113 ;; Strip out :state
114 (if (eq (car fields) :state)
115 (setq state (car (cdr fields)))
116 (setq newfields (cons (car (cdr fields))
117 (cons (car fields) newfields))))
118 (setq fields (cdr (cdr fields))))
120 (when (not state)
121 (error "Cannot create compound variable without :state"))
123 (call-next-method this (nreverse newfields))
124 (when (not (slot-boundp this 'compiled))
125 (let ((val (oref this :value))
126 (comp nil))
127 (while val
128 (let ((nval (car val))
130 (cond ((stringp nval)
131 (setq comp (cons nval comp)))
132 ((and (listp nval)
133 (equal (car nval) 'macro))
134 (require 'srecode/compile)
135 (setq comp (cons
136 (srecode-compile-parse-inserter
137 (cdr nval)
138 state)
139 comp)))
141 (error "Don't know how to handle variable value %S" nval)))
143 (setq val (cdr val)))
144 (oset this :compiled (nreverse comp))))))
146 ;;; DICTIONARY METHODS
149 (defun srecode-create-dictionary (&optional buffer-or-parent)
150 "Create a dictionary for BUFFER.
151 If BUFFER-OR-PARENT is not specified, assume a buffer, and
152 use the current buffer.
153 If BUFFER-OR-PARENT is another dictionary, then remember the
154 parent within the new dictionary, and assume that BUFFER
155 is the same as belongs to the parent dictionary.
156 The dictionary is initialized with variables setup for that
157 buffer's table.
158 If BUFFER-OR-PARENT is t, then this dictionary should not be
159 associated with a buffer or parent."
160 (save-excursion
161 ;; Handle the parent
162 (let ((parent nil)
163 (buffer nil)
164 (origin nil)
165 (initfrombuff nil))
166 (cond
167 ;; Parent is a buffer
168 ((bufferp buffer-or-parent)
169 (set-buffer buffer-or-parent)
170 (setq buffer buffer-or-parent
171 origin (buffer-name buffer-or-parent)
172 initfrombuff t))
174 ;; Parent is another dictionary
175 ((srecode-dictionary-child-p buffer-or-parent)
176 (setq parent buffer-or-parent
177 buffer (oref buffer-or-parent buffer)
178 origin (concat (object-name buffer-or-parent) " in "
179 (if buffer (buffer-name buffer)
180 "no buffer")))
181 (when buffer
182 (set-buffer buffer)))
184 ;; No parent
185 ((eq buffer-or-parent t)
186 (setq buffer nil
187 origin "Unspecified Origin"))
189 ;; Default to unspecified parent
191 (setq buffer (current-buffer)
192 origin (concat "Unspecified. Assume "
193 (buffer-name buffer))
194 initfrombuff t)))
196 ;; Create the new dictionary object.
197 (let ((dict (srecode-dictionary
198 major-mode
199 :buffer buffer
200 :parent parent
201 :namehash (make-hash-table :test 'equal
202 :size 20)
203 :origin origin)))
204 ;; Only set up the default variables if we are being built
205 ;; directroy for a particular buffer.
206 (when initfrombuff
207 ;; Variables from the table we are inserting from.
208 ;; @todo - get a better tree of tables.
209 (let ((mt (srecode-get-mode-table major-mode))
210 (def (srecode-get-mode-table 'default)))
211 ;; Each table has multiple template tables.
212 ;; Do DEF first so that MT can override any values.
213 (srecode-dictionary-add-template-table dict def)
214 (srecode-dictionary-add-template-table dict mt)
216 dict))))
218 (defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary)
219 tpl)
220 "Insert into DICT the variables found in table TPL.
221 TPL is an object representing a compiled template file."
222 (when tpl
223 (let ((tabs (oref tpl :tables)))
224 (require 'srecode/find) ; For srecode-template-table-in-project-p
225 (while tabs
226 (when (srecode-template-table-in-project-p (car tabs))
227 (let ((vars (oref (car tabs) variables)))
228 (while vars
229 (srecode-dictionary-set-value
230 dict (car (car vars)) (cdr (car vars)))
231 (setq vars (cdr vars)))))
232 (setq tabs (cdr tabs))))))
235 (defmethod srecode-dictionary-set-value ((dict srecode-dictionary)
236 name value)
237 "In dictionary DICT, set NAME to have VALUE."
238 ;; Validate inputs
239 (unless (stringp name)
240 (signal 'wrong-type-argument (list name 'stringp)))
242 ;; Add the value.
243 (with-slots (namehash) dict
244 (puthash name value namehash))
247 (defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary)
248 name &optional show-only force)
249 "In dictionary DICT, add a section dictionary for section macro NAME.
250 Return the new dictionary.
252 You can add several dictionaries to the same section entry.
253 For each dictionary added to a variable, the block of codes in
254 the template will be repeated.
256 If optional argument SHOW-ONLY is non-nil, then don't add a new dictionary
257 if there is already one in place. Also, don't add FIRST/LAST entries.
258 These entries are not needed when we are just showing a section.
260 Each dictionary added will automatically get values for positional macros
261 which will enable SECTIONS to be enabled.
263 * FIRST - The first entry in the table.
264 * NOTFIRST - Not the first entry in the table.
265 * LAST - The last entry in the table
266 * NOTLAST - Not the last entry in the table.
268 Adding a new dictionary will alter these values in previously
269 inserted dictionaries."
270 ;; Validate inputs
271 (unless (stringp name)
272 (signal 'wrong-type-argument (list name 'stringp)))
274 (let ((new (srecode-create-dictionary dict))
275 (ov (srecode-dictionary-lookup-name dict name t)))
277 (when (not show-only)
278 ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries.
279 (if (null ov)
280 (progn
281 (srecode-dictionary-show-section new "FIRST")
282 (srecode-dictionary-show-section new "LAST"))
283 ;; Not the very first one. Lets clean up CAR.
284 (let ((tail (car (last ov))))
285 (srecode-dictionary-hide-section tail "LAST")
286 (srecode-dictionary-show-section tail "NOTLAST")
288 (srecode-dictionary-show-section new "NOTFIRST")
289 (srecode-dictionary-show-section new "LAST"))
292 (when (or force
293 (not show-only)
294 (null ov))
295 (srecode-dictionary-set-value dict name (append ov (list new))))
296 ;; Return the new sub-dictionary.
297 new))
299 (defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name)
300 "In dictionary DICT, indicate that the section NAME should be exposed."
301 ;; Validate inputs
302 (unless (stringp name)
303 (signal 'wrong-type-argument (list name 'stringp)))
305 ;; Showing a section is just like making a section dictionary, but
306 ;; with no dictionary values to add.
307 (srecode-dictionary-add-section-dictionary dict name t)
308 nil)
310 (defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name)
311 "In dictionary DICT, indicate that the section NAME should be hidden."
312 ;; We need to find the has value, and then delete it.
313 ;; Validate inputs
314 (unless (stringp name)
315 (signal 'wrong-type-argument (list name 'stringp)))
317 ;; Add the value.
318 (with-slots (namehash) dict
319 (remhash name namehash))
320 nil)
322 (defmethod srecode-dictionary-add-entries ((dict srecode-dictionary)
323 entries &optional state)
324 "Add ENTRIES to DICT.
326 ENTRIES is a list of even length of dictionary entries to
327 add. ENTRIES looks like this:
329 (NAME_1 VALUE_1 NAME_2 VALUE_2 ...)
331 The following rules apply:
332 * NAME_N is a string
333 and for values
334 * If VALUE_N is t, the section NAME_N is shown.
335 * If VALUE_N is a string, an ordinary value is inserted.
336 * If VALUE_N is a dictionary, it is inserted as entry NAME_N.
337 * Otherwise, a compound variable is created for VALUE_N.
339 The optional argument STATE has to non-nil when compound values
340 are inserted. An error is signaled if ENTRIES contains compound
341 values but STATE is nil."
342 (while entries
343 (let ((name (nth 0 entries))
344 (value (nth 1 entries)))
345 (cond
346 ;; Value is t; show a section.
347 ((eq value t)
348 (srecode-dictionary-show-section dict name))
350 ;; Value is a simple string; create an ordinary dictionary
351 ;; entry
352 ((stringp value)
353 (srecode-dictionary-set-value dict name value))
355 ;; Value is a dictionary; insert as child dictionary.
356 ((srecode-dictionary-child-p value)
357 (srecode-dictionary-merge
358 (srecode-dictionary-add-section-dictionary dict name)
359 value t))
361 ;; Value is some other object; create a compound value.
363 (unless state
364 (error "Cannot insert compound values without state."))
366 (srecode-dictionary-set-value
367 dict name
368 (srecode-dictionary-compound-variable
369 name :value value :state state)))))
370 (setq entries (nthcdr 2 entries)))
371 dict)
373 (defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict
374 &optional force)
375 "Merge into DICT the dictionary entries from OTHERDICT.
376 Unless the optional argument FORCE is non-nil, values in DICT are
377 not modified, even if there are values of the same names in
378 OTHERDICT."
379 (when otherdict
380 (maphash
381 (lambda (key entry)
382 ;; The new values is only merged in if there was no old value
383 ;; or FORCE is non-nil.
385 ;; This protects applications from being whacked, and basically
386 ;; makes these new section dictionary entries act like
387 ;; "defaults" instead of overrides.
388 (when (or force
389 (not (srecode-dictionary-lookup-name dict key t)))
390 (cond
391 ;; A list of section dictionaries. We need to merge them in.
392 ((and (listp entry)
393 (srecode-dictionary-p (car entry)))
394 (dolist (sub-dict entry)
395 (srecode-dictionary-merge
396 (srecode-dictionary-add-section-dictionary
397 dict key t t)
398 sub-dict force)))
400 ;; Other values can be set directly.
402 (srecode-dictionary-set-value dict key entry)))))
403 (oref otherdict namehash))))
405 (defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary)
406 name &optional non-recursive)
407 "Return information about DICT's value for NAME.
408 DICT is a dictionary, and NAME is a string that is treated as the
409 name of an entry in the dictionary. If such an entry exists, its
410 value is returned. Otherwise, nil is returned. Normally, the
411 lookup is recursive in the sense that the parent of DICT is
412 searched for NAME if it is not found in DICT. This recursive
413 lookup can be disabled by the optional argument NON-RECURSIVE.
415 This function derives values for some special NAMEs, such as
416 'FIRST' and 'LAST'."
417 (if (not (slot-boundp dict 'namehash))
419 ;; Get the value of this name from the dictionary or its parent
420 ;; unless the lookup should be non-recursive.
421 (with-slots (namehash parent) dict
422 (or (gethash name namehash)
423 (and (not non-recursive)
424 (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST")))
425 parent
426 (srecode-dictionary-lookup-name parent name)))))
429 (defmethod srecode-root-dictionary ((dict srecode-dictionary))
430 "For dictionary DICT, return the root dictionary.
431 The root dictionary is usually for a current or active insertion."
432 (let ((ans dict))
433 (while (oref ans parent)
434 (setq ans (oref ans parent)))
435 ans))
437 ;;; COMPOUND VALUE METHODS
439 ;; Compound values must provide at least the toStriong method
440 ;; for use in converting the compound value into sometehing insertable.
442 (defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
443 function
444 dictionary)
445 "Convert the compound dictionary value CP to a string.
446 If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
447 of the compound value. The FUNCTION could be a fraction
448 of some function symbol with a logical prefix excluded.
450 If you subclass `srecode-dictionary-compound-value' then this
451 method could return nil, but if it does that, it must insert
452 the value itself using `princ', or by detecting if the current
453 standard out is a buffer, and using `insert'."
454 (object-name cp))
456 (defmethod srecode-dump ((cp srecode-dictionary-compound-value)
457 &optional indent)
458 "Display information about this compound value."
459 (princ (object-name cp))
462 (defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable)
463 function
464 dictionary)
465 "Convert the compound dictionary variable value CP into a string.
466 FUNCTION and DICTIONARY are as for the baseclass."
467 (require 'srecode/insert)
468 (srecode-insert-code-stream (oref cp compiled) dictionary))
471 (defmethod srecode-dump ((cp srecode-dictionary-compound-variable)
472 &optional indent)
473 "Display information about this compound value."
474 (require 'srecode/compile)
475 (princ "# Compound Variable #\n")
476 (let ((indent (+ 4 (or indent 0)))
477 (cmp (oref cp compiled))
479 (srecode-dump-code-list cmp (make-string indent ? ))
482 ;;; FIELD EDITING COMPOUND VALUE
484 ;; This is an interface to using field-editing objects
485 ;; instead of asking questions. This provides the basics
486 ;; behind this compound value.
488 (defclass srecode-field-value (srecode-dictionary-compound-value)
489 ((firstinserter :initarg :firstinserter
490 :documentation
491 "The inserter object for the first occurrence of this field.")
492 (defaultvalue :initarg :defaultvalue
493 :documentation
494 "The default value for this inserter.")
496 "When inserting values with editable field mode, a dictionary value.
497 Compound values allow a field to be stored in the dictionary for when
498 it is referenced a second time. This compound value can then be
499 inserted with a new editable field.")
501 (defmethod srecode-compound-toString((cp srecode-field-value)
502 function
503 dictionary)
504 "Convert this field into an insertable string."
505 (require 'srecode/fields)
506 ;; If we are not in a buffer, then this is not supported.
507 (when (not (bufferp standard-output))
508 (error "FIELDS invoked while inserting template to non-buffer"))
510 (if function
511 (error "@todo: Cannot mix field insertion with functions")
513 ;; No function. Perform a plain field insertion.
514 ;; We know we are in a buffer, so we can perform the insertion.
515 (let* ((dv (oref cp defaultvalue))
516 (sti (oref cp firstinserter))
517 (start (point))
518 (name (oref sti :object-name)))
520 (cond
521 ;; No default value.
522 ((not dv) (insert name))
523 ;; A compound value as the default? Recurse.
524 ((srecode-dictionary-compound-value-child-p dv)
525 (srecode-compound-toString dv function dictionary))
526 ;; A string that is empty? Use the name.
527 ((and (stringp dv) (string= dv ""))
528 (insert name))
529 ;; Insert strings
530 ((stringp dv) (insert dv))
531 ;; Some other issue
533 (error "Unknown default value for value %S" name)))
535 ;; Create a field from the inserter.
536 (srecode-field name :name name
537 :start start
538 :end (point)
539 :prompt (oref sti prompt)
540 :read-fcn (oref sti read-fcn)
543 ;; Returning nil is a signal that we have done the insertion ourselves.
544 nil)
547 ;;; Higher level dictionary functions
549 (defun srecode-create-section-dictionary (sectiondicts STATE)
550 "Create a dictionary with section entries for a template.
551 The format for SECTIONDICTS is what is emitted from the template parsers.
552 STATE is the current compiler state."
553 (when sectiondicts
554 (let ((new (srecode-create-dictionary t)))
555 ;; Loop over each section. The section is a macro w/in the
556 ;; template.
557 (while sectiondicts
558 (let* ((sect (car (car sectiondicts)))
559 (entries (cdr (car sectiondicts)))
560 (subdict (srecode-dictionary-add-section-dictionary new sect))
562 ;; Loop over each entry. This is one variable in the
563 ;; section dictionary.
564 (while entries
565 (let ((tname (semantic-tag-name (car entries)))
566 (val (semantic-tag-variable-default (car entries))))
567 (if (eq val t)
568 (srecode-dictionary-show-section subdict tname)
569 (cond
570 ((and (stringp (car val))
571 (= (length val) 1))
572 (setq val (car val)))
574 (setq val (srecode-dictionary-compound-variable
575 tname :value val :state STATE))))
576 (srecode-dictionary-set-value
577 subdict tname val))
578 (setq entries (cdr entries))))
580 (setq sectiondicts (cdr sectiondicts)))
581 new)))
583 (defun srecode-create-dictionaries-from-tags (tags state)
584 "Create a dictionary with entries according to TAGS.
586 TAGS should be in the format produced by the template file
587 grammar. That is
589 TAGS = (ENTRY_1 ENTRY_2 ...)
591 where
593 ENTRY_N = (NAME ENTRY_N_1 ENTRY_N_2 ...) | TAG
595 where TAG is a semantic tag of class 'variable. The (NAME ... )
596 form creates a child dictionary which is stored under the name
597 NAME. The TAG form creates a value entry or section dictionary
598 entry whose name is the name of the tag.
600 STATE is the current compiler state."
601 (let ((dict (srecode-create-dictionary t))
602 (entries (apply #'append
603 (mapcar
604 (lambda (entry)
605 (cond
606 ;; Entry is a tag
607 ((semantic-tag-p entry)
608 (let ((name (semantic-tag-name entry))
609 (value (semantic-tag-variable-default entry)))
610 (list name
611 (if (and (listp value)
612 (= (length value) 1)
613 (stringp (car value)))
614 (car value)
615 value))))
617 ;; Entry is a nested dictionary
619 (let ((name (car entry))
620 (entries (cdr entry)))
621 (list name
622 (srecode-create-dictionaries-from-tags
623 entries state))))))
624 tags))))
625 (srecode-dictionary-add-entries
626 dict entries state)
627 dict)
630 ;;; DUMP DICTIONARY
632 ;; Make a dictionary, and dump it's contents.
634 (defun srecode-adebug-dictionary ()
635 "Run data-debug on this mode's dictionary."
636 (interactive)
637 (require 'eieio-datadebug)
638 (require 'semantic)
639 (require 'srecode/find)
640 (let* ((modesym major-mode)
641 (start (current-time))
642 (junk (or (progn (srecode-load-tables-for-mode modesym)
643 (srecode-get-mode-table modesym))
644 (error "No table found for mode %S" modesym)))
645 (dict (srecode-create-dictionary (current-buffer)))
646 (end (current-time))
648 (message "Creating a dictionary took %.2f seconds."
649 (semantic-elapsed-time start end))
650 (data-debug-new-buffer "*SRECODE ADEBUG*")
651 (data-debug-insert-object-slots dict "*")))
653 (defun srecode-dictionary-dump ()
654 "Dump a typical fabricated dictionary."
655 (interactive)
656 (require 'srecode/find)
657 (let ((modesym major-mode))
658 ;; This load allows the dictionary access to inherited
659 ;; and stacked dictionary entries.
660 (srecode-load-tables-for-mode modesym)
661 (let ((tmp (srecode-get-mode-table modesym))
663 (if (not tmp)
664 (error "No table found for mode %S" modesym))
665 ;; Now make the dictionary.
666 (let ((dict (srecode-create-dictionary (current-buffer))))
667 (with-output-to-temp-buffer "*SRECODE DUMP*"
668 (princ "DICTIONARY FOR ")
669 (princ major-mode)
670 (princ "\n--------------------------------------------\n")
671 (srecode-dump dict))
672 ))))
674 (defmethod srecode-dump ((dict srecode-dictionary) &optional indent)
675 "Dump a dictionary."
676 (if (not indent) (setq indent 0))
677 (maphash (lambda (key entry)
678 (princ (make-string indent ? ))
679 (princ " ")
680 (princ key)
681 (princ " ")
682 (cond ((and (listp entry)
683 (srecode-dictionary-p (car entry)))
684 (let ((newindent (if indent
685 (+ indent 4)
686 4)))
687 (while entry
688 (princ " --> SUBDICTIONARY ")
689 (princ (object-name dict))
690 (princ "\n")
691 (srecode-dump (car entry) newindent)
692 (setq entry (cdr entry))
694 (princ "\n")
696 ((srecode-dictionary-compound-value-child-p entry)
697 (srecode-dump entry indent)
698 (princ "\n")
701 (prin1 entry)
702 ;(princ "\n")
704 (terpri)
706 (oref dict namehash))
709 (provide 'srecode/dictionary)
711 ;;; srecode/dictionary.el ends here