1 ;;; srecode/dictionary.el --- Dictionary code for the semantic recoder.
3 ;; Copyright (C) 2007-2017 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/>.
24 ;; Dictionaries contain lists of names and their associated values.
25 ;; These dictionaries are used to fill in macros from recoder templates.
31 (eval-when-compile (require 'cl
))
35 (require 'srecode
/table
)
36 (eval-when-compile (require 'semantic
))
38 (declare-function srecode-compile-parse-inserter
"srecode/compile")
39 (declare-function srecode-dump-code-list
"srecode/compile")
40 (declare-function srecode-load-tables-for-mode
"srecode/find")
41 (declare-function srecode-template-table-in-project-p
"srecode/find")
42 (declare-function srecode-insert-code-stream
"srecode/insert")
43 (declare-function data-debug-new-buffer
"data-debug")
44 (declare-function data-debug-insert-object-slots
"eieio-datadebug")
45 (declare-function srecode-field
"srecode/fields")
47 (defclass srecode-dictionary
()
48 ((namehash :initarg
:namehash
50 "Hash table containing the names of all the templates.")
51 (buffer :initarg
:buffer
53 "The buffer this dictionary was initialized with.")
54 (parent :initarg
:parent
55 :type
(or null srecode-dictionary
)
57 "The parent dictionary.
58 Symbols not appearing in this dictionary will be checked against the
60 (origin :initarg
:origin
63 "A string representing the origin of this dictionary.
64 Useful only while debugging.")
66 "Dictionary of symbols and what they mean.
67 Dictionaries are used to look up named symbols from
68 templates to decide what to do with those symbols.")
70 (defclass srecode-dictionary-compound-value
()
72 "A compound dictionary value.
73 Values stored in a dictionary must be a STRING,
74 a dictionary for showing sections, or an instance of a subclass
77 Compound dictionary values derive from this class, and must
78 provide a sequence of method implementations to convert into
82 (defclass srecode-dictionary-compound-variable
83 (srecode-dictionary-compound-value)
84 ((value :initarg
:value
86 "The value of this template variable.
87 Variables in template files are usually a single string
88 which can be inserted into a dictionary directly.
90 Some variables may be more complex and involve dictionary
91 lookups, strings, concatenation, or the like.
93 The format of VALUE is determined by current template
95 (compiled :initarg
:compiled
98 "The compiled version of VALUE.")
100 "A compound dictionary value for template file variables.
101 You can declare a variable in a template like this:
103 set NAME \"str\" macro \"OTHERNAME\"
105 with appending various parts together in a list.")
107 (cl-defmethod initialize-instance ((this srecode-dictionary-compound-variable
)
109 "Initialize the compound variable THIS.
110 Makes sure that :value is compiled."
111 (let ((newfields nil
)
115 (if (eq (car fields
) :state
)
116 (setq state
(car (cdr fields
)))
117 (setq newfields
(cons (car (cdr fields
))
118 (cons (car fields
) newfields
))))
119 (setq fields
(cdr (cdr fields
))))
122 ;; (error "Cannot create compound variable outside of sectiondictionary"))
124 (cl-call-next-method this
(nreverse newfields
))
125 (when (not (slot-boundp this
'compiled
))
126 (let ((val (oref this
:value
))
129 (let ((nval (car val
))
131 (cond ((stringp nval
)
132 (setq comp
(cons nval comp
)))
134 (equal (car nval
) 'macro
))
135 (require 'srecode
/compile
)
137 (srecode-compile-parse-inserter
142 (error "Don't know how to handle variable value %S" nval
)))
144 (setq val
(cdr val
)))
145 (oset this
:compiled
(nreverse comp
))))))
147 ;;; DICTIONARY METHODS
150 (defun srecode-create-dictionary (&optional buffer-or-parent
)
151 "Create a dictionary for BUFFER.
152 If BUFFER-OR-PARENT is not specified, assume a buffer, and
153 use the current buffer.
154 If BUFFER-OR-PARENT is another dictionary, then remember the
155 parent within the new dictionary, and assume that BUFFER
156 is the same as belongs to the parent dictionary.
157 The dictionary is initialized with variables setup for that
159 If BUFFER-OR-PARENT is t, then this dictionary should not be
160 associated with a buffer or parent."
168 ;; Parent is a buffer
169 ((bufferp buffer-or-parent
)
170 (set-buffer buffer-or-parent
)
171 (setq buffer buffer-or-parent
172 origin
(buffer-name buffer-or-parent
)
175 ;; Parent is another dictionary
176 ((srecode-dictionary-child-p buffer-or-parent
)
177 (setq parent buffer-or-parent
178 buffer
(oref buffer-or-parent buffer
)
179 origin
(concat (eieio-object-name buffer-or-parent
) " in "
180 (if buffer
(buffer-name buffer
)
183 (set-buffer buffer
)))
186 ((eq buffer-or-parent t
)
188 origin
"Unspecified Origin"))
190 ;; Default to unspecified parent
192 (setq buffer
(current-buffer)
193 origin
(concat "Unspecified. Assume "
194 (buffer-name buffer
))
197 ;; Create the new dictionary object.
198 (let ((dict (make-instance
202 :namehash
(make-hash-table :test
'equal
205 ;; Only set up the default variables if we are being built
206 ;; directly for a particular buffer.
208 ;; Variables from the table we are inserting from.
209 ;; @todo - get a better tree of tables.
210 (let ((mt (srecode-get-mode-table major-mode
))
211 (def (srecode-get-mode-table 'default
)))
212 ;; Each table has multiple template tables.
213 ;; Do DEF first so that MT can override any values.
214 (srecode-dictionary-add-template-table dict def
)
215 (srecode-dictionary-add-template-table dict mt
)
219 (cl-defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary
)
221 "Insert into DICT the variables found in table TPL.
222 TPL is an object representing a compiled template file."
224 ;; Tables are sorted with highest priority first, useful for looking
225 ;; up templates, but this means we need to install the variables in
226 ;; reverse order so higher priority variables override lower ones.
227 (let ((tabs (reverse (oref tpl
:tables
))))
228 (require 'srecode
/find
) ; For srecode-template-table-in-project-p
230 (when (srecode-template-table-in-project-p (car tabs
))
231 (let ((vars (oref (car tabs
) variables
)))
233 (srecode-dictionary-set-value
234 dict
(car (car vars
)) (cdr (car vars
)))
235 (setq vars
(cdr vars
)))))
236 (setq tabs
(cdr tabs
))))))
239 (cl-defmethod srecode-dictionary-set-value ((dict srecode-dictionary
)
241 "In dictionary DICT, set NAME to have VALUE."
243 (unless (stringp name
)
244 (signal 'wrong-type-argument
(list name
'stringp
)))
247 (with-slots (namehash) dict
248 (puthash name value namehash
))
251 (cl-defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary
)
252 name
&optional show-only force
)
253 "In dictionary DICT, add a section dictionary for section macro NAME.
254 Return the new dictionary.
256 You can add several dictionaries to the same section entry.
257 For each dictionary added to a variable, the block of codes in
258 the template will be repeated.
260 If optional argument SHOW-ONLY is non-nil, then don't add a new dictionary
261 if there is already one in place. Also, don't add FIRST/LAST entries.
262 These entries are not needed when we are just showing a section.
264 Each dictionary added will automatically get values for positional macros
265 which will enable SECTIONS to be enabled.
267 * FIRST - The first entry in the table.
268 * NOTFIRST - Not the first entry in the table.
269 * LAST - The last entry in the table
270 * NOTLAST - Not the last entry in the table.
272 Adding a new dictionary will alter these values in previously
273 inserted dictionaries."
275 (unless (stringp name
)
276 (signal 'wrong-type-argument
(list name
'stringp
)))
278 (let ((new (srecode-create-dictionary dict
))
279 (ov (srecode-dictionary-lookup-name dict name t
)))
281 (when (not show-only
)
282 ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries.
285 (srecode-dictionary-show-section new
"FIRST")
286 (srecode-dictionary-show-section new
"LAST"))
287 ;; Not the very first one. Let's clean up CAR.
288 (let ((tail (car (last ov
))))
289 (srecode-dictionary-hide-section tail
"LAST")
290 (srecode-dictionary-show-section tail
"NOTLAST")
292 (srecode-dictionary-show-section new
"NOTFIRST")
293 (srecode-dictionary-show-section new
"LAST"))
299 (srecode-dictionary-set-value dict name
(append ov
(list new
))))
300 ;; Return the new sub-dictionary.
303 (cl-defmethod srecode-dictionary-show-section ((dict srecode-dictionary
) name
)
304 "In dictionary DICT, indicate that the section NAME should be exposed."
306 (unless (stringp name
)
307 (signal 'wrong-type-argument
(list name
'stringp
)))
309 ;; Showing a section is just like making a section dictionary, but
310 ;; with no dictionary values to add.
311 (srecode-dictionary-add-section-dictionary dict name t
)
314 (cl-defmethod srecode-dictionary-hide-section ((dict srecode-dictionary
) name
)
315 "In dictionary DICT, indicate that the section NAME should be hidden."
316 ;; We need to find the has value, and then delete it.
318 (unless (stringp name
)
319 (signal 'wrong-type-argument
(list name
'stringp
)))
322 (with-slots (namehash) dict
323 (remhash name namehash
))
326 (cl-defmethod srecode-dictionary-add-entries ((dict srecode-dictionary
)
327 entries
&optional state
)
328 "Add ENTRIES to DICT.
330 ENTRIES is a list of even length of dictionary entries to
331 add. ENTRIES looks like this:
333 (NAME_1 VALUE_1 NAME_2 VALUE_2 ...)
335 The following rules apply:
338 * If VALUE_N is t, the section NAME_N is shown.
339 * If VALUE_N is a string, an ordinary value is inserted.
340 * If VALUE_N is a dictionary, it is inserted as entry NAME_N.
341 * Otherwise, a compound variable is created for VALUE_N.
343 The optional argument STATE has to non-nil when compound values
344 are inserted. An error is signaled if ENTRIES contains compound
345 values but STATE is nil."
347 (let ((name (nth 0 entries
))
348 (value (nth 1 entries
)))
350 ;; Value is t; show a section.
352 (srecode-dictionary-show-section dict name
))
354 ;; Value is a simple string; create an ordinary dictionary
357 (srecode-dictionary-set-value dict name value
))
359 ;; Value is a dictionary; insert as child dictionary.
360 ((srecode-dictionary-child-p value
)
361 (srecode-dictionary-merge
362 (srecode-dictionary-add-section-dictionary dict name
)
365 ;; Value is some other object; create a compound value.
368 (error "Cannot insert compound values without state."))
370 (srecode-dictionary-set-value
372 (srecode-dictionary-compound-variable
373 name
:value value
:state state
)))))
374 (setq entries
(nthcdr 2 entries
)))
377 (cl-defmethod srecode-dictionary-merge ((dict srecode-dictionary
) otherdict
379 "Merge into DICT the dictionary entries from OTHERDICT.
380 Unless the optional argument FORCE is non-nil, values in DICT are
381 not modified, even if there are values of the same names in
386 ;; The new values is only merged in if there was no old value
387 ;; or FORCE is non-nil.
389 ;; This protects applications from being whacked, and basically
390 ;; makes these new section dictionary entries act like
391 ;; "defaults" instead of overrides.
393 (not (srecode-dictionary-lookup-name dict key t
)))
395 ;; A list of section dictionaries. We need to merge them in.
397 (srecode-dictionary-p (car entry
)))
398 (dolist (sub-dict entry
)
399 (srecode-dictionary-merge
400 (srecode-dictionary-add-section-dictionary
404 ;; Other values can be set directly.
406 (srecode-dictionary-set-value dict key entry
)))))
407 (oref otherdict namehash
))))
409 (cl-defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary
)
410 name
&optional non-recursive
)
411 "Return information about DICT's value for NAME.
412 DICT is a dictionary, and NAME is a string that is treated as the
413 name of an entry in the dictionary. If such an entry exists, its
414 value is returned. Otherwise, nil is returned. Normally, the
415 lookup is recursive in the sense that the parent of DICT is
416 searched for NAME if it is not found in DICT. This recursive
417 lookup can be disabled by the optional argument NON-RECURSIVE.
419 This function derives values for some special NAMEs, such as
421 (if (not (slot-boundp dict
'namehash
))
423 ;; Get the value of this name from the dictionary or its parent
424 ;; unless the lookup should be non-recursive.
425 (with-slots (namehash parent
) dict
426 (or (gethash name namehash
)
427 (and (not non-recursive
)
428 (not (member name
'("FIRST" "LAST" "NOTFIRST" "NOTLAST")))
430 (srecode-dictionary-lookup-name parent name
)))))
433 (cl-defmethod srecode-root-dictionary ((dict srecode-dictionary
))
434 "For dictionary DICT, return the root dictionary.
435 The root dictionary is usually for a current or active insertion."
437 (while (oref ans parent
)
438 (setq ans
(oref ans parent
)))
441 ;;; COMPOUND VALUE METHODS
443 ;; Compound values must provide at least the toString method
444 ;; for use in converting the compound value into something insertable.
446 (cl-defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value
)
449 "Convert the compound dictionary value CP to a string.
450 If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
451 of the compound value. The FUNCTION could be a fraction
452 of some function symbol with a logical prefix excluded.
454 If you subclass `srecode-dictionary-compound-value' then this
455 method could return nil, but if it does that, it must insert
456 the value itself using `princ', or by detecting if the current
457 standard out is a buffer, and using `insert'."
458 (eieio-object-name cp
))
460 (cl-defmethod srecode-dump ((cp srecode-dictionary-compound-value
)
462 "Display information about this compound value."
463 (princ (eieio-object-name cp
))
466 (cl-defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable
)
469 "Convert the compound dictionary variable value CP into a string.
470 FUNCTION and DICTIONARY are as for the baseclass."
471 (require 'srecode
/insert
)
472 (srecode-insert-code-stream (oref cp compiled
) dictionary
))
475 (cl-defmethod srecode-dump ((cp srecode-dictionary-compound-variable
)
477 "Display information about this compound value."
478 (require 'srecode
/compile
)
479 (princ "# Compound Variable #\n")
480 (let ((indent (+ 4 (or indent
0)))
481 (cmp (oref cp compiled
))
483 (srecode-dump-code-list cmp
(make-string indent ?
))
486 ;;; FIELD EDITING COMPOUND VALUE
488 ;; This is an interface to using field-editing objects
489 ;; instead of asking questions. This provides the basics
490 ;; behind this compound value.
492 (defclass srecode-field-value
(srecode-dictionary-compound-value)
493 ((firstinserter :initarg
:firstinserter
495 "The inserter object for the first occurrence of this field.")
496 (defaultvalue :initarg
:defaultvalue
498 "The default value for this inserter.")
500 "When inserting values with editable field mode, a dictionary value.
501 Compound values allow a field to be stored in the dictionary for when
502 it is referenced a second time. This compound value can then be
503 inserted with a new editable field.")
505 (cl-defmethod srecode-compound-toString((cp srecode-field-value
)
508 "Convert this field into an insertable string."
509 (require 'srecode
/fields
)
510 ;; If we are not in a buffer, then this is not supported.
511 (when (not (bufferp standard-output
))
512 (error "FIELDS invoked while inserting template to non-buffer"))
515 (error "@todo: Cannot mix field insertion with functions")
517 ;; No function. Perform a plain field insertion.
518 ;; We know we are in a buffer, so we can perform the insertion.
519 (let* ((dv (oref cp defaultvalue
))
520 (sti (oref cp firstinserter
))
522 (name (oref sti
:object-name
)))
526 ((not dv
) (insert name
))
527 ;; A compound value as the default? Recurse.
528 ((srecode-dictionary-compound-value-child-p dv
)
529 (srecode-compound-toString dv function dictionary
))
530 ;; A string that is empty? Use the name.
531 ((and (stringp dv
) (string= dv
""))
534 ((stringp dv
) (insert dv
))
537 (error "Unknown default value for value %S" name
)))
539 ;; Create a field from the inserter.
540 (srecode-field name
:name name
543 :prompt
(oref sti prompt
)
544 :read-fcn
(oref sti read-fcn
)
547 ;; Returning nil is a signal that we have done the insertion ourselves.
551 ;;; Higher level dictionary functions
553 (defun srecode-create-dictionaries-from-tags (tags state
)
554 "Create a dictionary with entries according to TAGS.
556 TAGS should be in the format produced by the template file
559 TAGS = (ENTRY_1 ENTRY_2 ...)
563 ENTRY_N = (NAME ENTRY_N_1 ENTRY_N_2 ...) | TAG
565 where TAG is a semantic tag of class 'variable. The (NAME ... )
566 form creates a child dictionary which is stored under the name
567 NAME. The TAG form creates a value entry or section dictionary
568 entry whose name is the name of the tag.
570 STATE is the current compiler state."
571 (let ((dict (srecode-create-dictionary t
))
572 (entries (apply #'append
577 ((semantic-tag-p entry
)
578 (let ((name (semantic-tag-name entry
))
579 (value (semantic-tag-variable-default entry
)))
581 (if (and (listp value
)
583 (stringp (car value
)))
587 ;; Entry is a nested dictionary
589 (let ((name (car entry
))
590 (entries (cdr entry
)))
592 (srecode-create-dictionaries-from-tags
595 (srecode-dictionary-add-entries
602 ;; Make a dictionary, and dump it's contents.
604 (defun srecode-adebug-dictionary ()
605 "Run data-debug on this mode's dictionary."
607 (require 'eieio-datadebug
)
608 (require 'srecode
/find
)
609 (let* ((modesym major-mode
)
610 (start (current-time))
611 (junk (or (progn (srecode-load-tables-for-mode modesym
)
612 (srecode-get-mode-table modesym
))
613 (error "No table found for mode %S" modesym
)))
614 (dict (srecode-create-dictionary (current-buffer)))
617 (message "Creating a dictionary took %.2f seconds."
618 (semantic-elapsed-time start end
))
619 (data-debug-new-buffer "*SRECODE ADEBUG*")
620 (data-debug-insert-object-slots dict
"*")))
622 (defun srecode-dictionary-dump ()
623 "Dump a typical fabricated dictionary."
625 (require 'srecode
/find
)
626 (let ((modesym major-mode
))
627 ;; This load allows the dictionary access to inherited
628 ;; and stacked dictionary entries.
629 (srecode-load-tables-for-mode modesym
)
630 (let ((tmp (srecode-get-mode-table modesym
))
633 (error "No table found for mode %S" modesym
))
634 ;; Now make the dictionary.
635 (let ((dict (srecode-create-dictionary (current-buffer))))
636 (with-output-to-temp-buffer "*SRECODE DUMP*"
637 (princ "DICTIONARY FOR ")
639 (princ "\n--------------------------------------------\n")
643 (cl-defmethod srecode-dump ((dict srecode-dictionary
) &optional indent
)
645 (if (not indent
) (setq indent
0))
646 (maphash (lambda (key entry
)
647 (princ (make-string indent ?
))
651 (cond ((and (listp entry
)
652 (srecode-dictionary-p (car entry
)))
653 (let ((newindent (if indent
657 (princ " --> SUBDICTIONARY ")
658 (princ (eieio-object-name dict
))
660 (srecode-dump (car entry
) newindent
)
661 (setq entry
(cdr entry
))
665 ((srecode-dictionary-compound-value-child-p entry
)
666 (srecode-dump entry indent
)
675 (oref dict namehash
))
678 (provide 'srecode
/dictionary
)
680 ;;; srecode/dictionary.el ends here