lisp/cedet/srecode/dictionary.el

   1 ;;; srecode-dictionary.el --- Dictionary code for the semantic recoder.
   2
   3 ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   6
   7 ;; This file is part of GNU Emacs.
   8
   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.
  13
  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.
  18
  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/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Dictionaries contain lists of names and their associated values.
  25 ;; These dictionaries are used to fill in macros from recoder templates.
  26
  27 ;;; Code:
  28
  29 ;;; CLASSES
  30
  31 (eval-when-compile (require 'cl))
  32 (require 'eieio)
  33 (require 'srecode)
  34 (require 'srecode/table)
  35 (eval-when-compile (require 'semantic))
  36
  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-insert-code-stream "srecode/insert")
  41 (declare-function data-debug-new-buffer "data-debug")
  42 (declare-function data-debug-insert-object-slots "eieio-datadebug")
  43 (declare-function srecode-field "srecode/fields")
  44
  45 (defclass srecode-dictionary ()
  46   ((namehash :initarg :namehash
  47              :documentation
  48              "Hash table containing the names of all the templates.")
  49    (buffer :initarg :buffer
  50            :documentation
  51            "The buffer this dictionary was initialized with.")
  52    (parent :initarg :parent
  53            :type (or null srecode-dictionary)
  54            :documentation
  55            "The parent dictionary.
  56 Symbols not appearing in this dictionary will be checked against the
  57 parent dictionary.")
  58    (origin :initarg :origin
  59            :type string
  60            :documentation
  61            "A string representing the origin of this dictionary.
  62 Useful only while debugging.")
  63    )
  64   "Dictionary of symbols and what they mean.
  65 Dictionaries are used to look up named symbols from
  66 templates to decide what to do with those symbols.")
  67
  68 (defclass srecode-dictionary-compound-value ()
  69   ()
  70   "A compound dictionary value.
  71 Values stored in a dictionary must be a STRING,
  72 a dictionary for showing sections, or an instance of a subclass
  73 of this class.
  74
  75 Compound dictionary values derive from this class, and must
  76 provide a sequence of method implementations to convert into
  77 a string."
  78   :abstract t)
  79
  80 (defclass srecode-dictionary-compound-variable
  81   (srecode-dictionary-compound-value)
  82   ((value :initarg :value
  83           :documentation
  84           "The value of this template variable.
  85 Variables in template files are usually a single string
  86 which can be inserted into a dictionary directly.
  87
  88 Some variables may be more complex and involve dictionary
  89 lookups, strings, concatenation, or the like.
  90
  91 The format of VALUE is determined by current template
  92 formatting rules.")
  93    (compiled :initarg :compiled
  94              :type list
  95              :documentation
  96              "The compiled version of VALUE.")
  97    )
  98   "A compound dictionary value for template file variables.
  99 You can declare a variable in a template like this:
 100
 101 set NAME \"str\" macro \"OTHERNAME\"
 102
 103 with appending various parts together in a list.")
 104
 105 (defmethod initialize-instance ((this srecode-dictionary-compound-variable)
 106                                 &optional fields)
 107   "Initialize the compound variable THIS.
 108 Makes sure that :value is compiled."
 109   (let ((newfields nil)
 110         (state nil))
 111     (while fields
 112       ;; Strip out :state
 113       (if (eq (car fields) :state)
 114           (setq state (car (cdr fields)))
 115         (setq newfields (cons (car (cdr fields))
 116                               (cons (car fields) newfields))))
 117       (setq fields (cdr (cdr fields))))
 118
 119     (when (not state)
 120       (error "Cannot create compound variable without :state"))
 121
 122     (call-next-method this (nreverse newfields))
 123     (when (not (slot-boundp this 'compiled))
 124       (let ((val (oref this :value))
 125             (comp nil))
 126         (while val
 127           (let ((nval (car val))
 128                 )
 129             (cond ((stringp nval)
 130                    (setq comp (cons nval comp)))
 131                   ((and (listp nval)
 132                         (equal (car nval) 'macro))
 133                    (require 'srecode/compile)
 134                    (setq comp (cons
 135                                (srecode-compile-parse-inserter
 136                                 (cdr nval)
 137                                 state)
 138                                comp)))
 139                   (t
 140                    (error "Don't know how to handle variable value %S" nval)))
 141             )
 142           (setq val (cdr val)))
 143         (oset this :compiled (nreverse comp))))))
 144
 145 ;;; DICTIONARY METHODS
 146 ;;
 147
 148 (defun srecode-create-dictionary (&optional buffer-or-parent)
 149   "Create a dictionary for BUFFER.
 150 If BUFFER-OR-PARENT is not specified, assume a buffer, and
 151 use the current buffer.
 152 If BUFFER-OR-PARENT is another dictionary, then remember the
 153 parent within the new dictionary, and assume that BUFFER
 154 is the same as belongs to the parent dictionary.
 155 The dictionary is initialized with variables setup for that
 156 buffer's table.
 157 If BUFFER-OR-PARENT is t, then this dictionary should not be
 158 associated with a buffer or parent."
 159   (save-excursion
 160     (let ((parent nil)
 161           (buffer nil)
 162           (origin nil)
 163           (initfrombuff nil))
 164       (cond ((bufferp buffer-or-parent)
 165              (set-buffer buffer-or-parent)
 166              (setq buffer buffer-or-parent
 167                    origin (buffer-name buffer-or-parent)
 168                    initfrombuff t))
 169             ((srecode-dictionary-child-p buffer-or-parent)
 170              (setq parent buffer-or-parent
 171                    buffer (oref buffer-or-parent buffer)
 172                    origin (concat (object-name buffer-or-parent) " in "
 173                                   (if buffer (buffer-name buffer)
 174                                     "no buffer")))
 175              (when buffer
 176                (set-buffer buffer)))
 177             ((eq buffer-or-parent t)
 178              (setq buffer nil
 179                    origin "Unspecified Origin"))
 180             (t
 181              (setq buffer (current-buffer)
 182                    origin (concat "Unspecified.  Assume "
 183                                   (buffer-name buffer))
 184                    initfrombuff t)
 185              )
 186             )
 187       (let ((dict (srecode-dictionary
 188                    major-mode
 189                    :buffer buffer
 190                    :parent parent
 191                    :namehash  (make-hash-table :test 'equal
 192                                                :size 20)
 193                    :origin origin)))
 194         ;; Only set up the default variables if we are being built
 195         ;; directroy for a particular buffer.
 196         (when initfrombuff
 197           ;; Variables from the table we are inserting from.
 198           ;; @todo - get a better tree of tables.
 199           (let ((mt (srecode-get-mode-table major-mode))
 200                 (def (srecode-get-mode-table 'default)))
 201             ;; Each table has multiple template tables.
 202             ;; Do DEF first so that MT can override any values.
 203             (srecode-dictionary-add-template-table dict def)
 204             (srecode-dictionary-add-template-table dict mt)
 205             ))
 206         dict))))
 207
 208 (defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary)
 209                                                   tpl)
 210   "Insert into DICT the variables found in table TPL.
 211 TPL is an object representing a compiled template file."
 212   (when tpl
 213     (let ((tabs (oref tpl :tables)))
 214       (while tabs
 215         (let ((vars (oref (car tabs) variables)))
 216           (while vars
 217             (srecode-dictionary-set-value
 218              dict (car (car vars)) (cdr (car vars)))
 219             (setq vars (cdr vars))))
 220         (setq tabs (cdr tabs))))))
 221
 222
 223 (defmethod srecode-dictionary-set-value ((dict srecode-dictionary)
 224                                          name value)
 225   "In dictionary DICT, set NAME to have VALUE."
 226   ;; Validate inputs
 227   (if (not (stringp name))
 228       (signal 'wrong-type-argument (list name 'stringp)))
 229   ;; Add the value.
 230   (with-slots (namehash) dict
 231     (puthash name value namehash))
 232   )
 233
 234 (defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary)
 235                                                       name &optional show-only)
 236   "In dictionary DICT, add a section dictionary for section macro NAME.
 237 Return the new dictionary.
 238
 239 You can add several dictionaries to the same section macro.
 240 For each dictionary added to a macro, the block of codes in the
 241 template will be repeated.
 242
 243 If optional argument SHOW-ONLY is non-nil, then don't add a new dictionary
 244 if there is already one in place.  Also, don't add FIRST/LAST entries.
 245 These entries are not needed when we are just showing a section.
 246
 247 Each dictionary added will automatically get values for positional macros
 248 which will enable SECTIONS to be enabled.
 249
 250  * FIRST - The first entry in the table.
 251  * NOTFIRST - Not the first entry in the table.
 252  * LAST - The last entry in the table
 253  * NOTLAST - Not the last entry in the table.
 254
 255 Adding a new dictionary will alter these values in previously
 256 inserted dictionaries."
 257   ;; Validate inputs
 258   (if (not (stringp name))
 259       (signal 'wrong-type-argument (list name 'stringp)))
 260   (let ((new (srecode-create-dictionary dict))
 261         (ov (srecode-dictionary-lookup-name dict name)))
 262
 263     (when (not show-only)
 264       ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries.
 265       (if (null ov)
 266           (progn
 267             (srecode-dictionary-show-section new "FIRST")
 268             (srecode-dictionary-show-section new "LAST"))
 269         ;; Not the very first one.  Lets clean up CAR.
 270         (let ((tail (car (last ov))))
 271           (srecode-dictionary-hide-section tail "LAST")
 272           (srecode-dictionary-show-section tail "NOTLAST")
 273           )
 274         (srecode-dictionary-show-section new "NOTFIRST")
 275         (srecode-dictionary-show-section new "LAST"))
 276       )
 277
 278     (when (or (not show-only) (null ov))
 279       (srecode-dictionary-set-value dict name (append ov (list new))))
 280     ;; Return the new sub-dictionary.
 281     new))
 282
 283 (defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name)
 284   "In dictionary DICT, indicate that the section NAME should be exposed."
 285   ;; Validate inputs
 286   (if (not (stringp name))
 287       (signal 'wrong-type-argument (list name 'stringp)))
 288   ;; Showing a section is just like making a section dictionary, but
 289   ;; with no dictionary values to add.
 290   (srecode-dictionary-add-section-dictionary dict name t)
 291   nil)
 292
 293 (defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name)
 294   "In dictionary DICT, indicate that the section NAME should be hidden."
 295   ;; We need to find the has value, and then delete it.
 296   ;; Validate inputs
 297   (if (not (stringp name))
 298       (signal 'wrong-type-argument (list name 'stringp)))
 299   ;; Add the value.
 300   (with-slots (namehash) dict
 301     (remhash name namehash))
 302   nil)
 303
 304 (defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict)
 305   "Merge into DICT the dictionary entries from OTHERDICT."
 306   (when otherdict
 307     (maphash
 308      (lambda (key entry)
 309        ;; Only merge in the new values if there was no old value.
 310        ;; This protects applications from being whacked, and basically
 311        ;; makes these new section dictionary entries act like
 312        ;; "defaults" instead of overrides.
 313        (when (not (srecode-dictionary-lookup-name dict key))
 314          (cond ((and (listp entry) (srecode-dictionary-p (car entry)))
 315                 ;; A list of section dictionaries.
 316                 ;; We need to merge them in.
 317                 (while entry
 318                   (let ((new-sub-dict
 319                          (srecode-dictionary-add-section-dictionary
 320                           dict key)))
 321                     (srecode-dictionary-merge new-sub-dict (car entry)))
 322                   (setq entry (cdr entry)))
 323                   )
 324
 325                (t
 326                 (srecode-dictionary-set-value dict key entry)))
 327                ))
 328      (oref otherdict namehash))))
 329
 330 (defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary)
 331                                            name)
 332   "Return information about the current DICT's value for NAME."
 333   (if (not (slot-boundp dict 'namehash))
 334       nil
 335     ;; Get the value of this name from the dictionary
 336     (or (with-slots (namehash) dict
 337           (gethash name namehash))
 338         (and (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST")))
 339              (oref dict parent)
 340              (srecode-dictionary-lookup-name (oref dict parent) name))
 341         )))
 342
 343 (defmethod srecode-root-dictionary ((dict srecode-dictionary))
 344   "For dictionary DICT, return the root dictionary.
 345 The root dictionary is usually for a current or active insertion."
 346   (let ((ans dict))
 347     (while (oref ans parent)
 348       (setq ans (oref ans parent)))
 349     ans))
 350
 351 ;;; COMPOUND VALUE METHODS
 352 ;;
 353 ;; Compound values must provide at least the toStriong method
 354 ;; for use in converting the compound value into sometehing insertable.
 355
 356 (defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
 357                                       function
 358                                       dictionary)
 359   "Convert the compound dictionary value CP to a string.
 360 If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
 361 of the compound value.  The FUNCTION could be a fraction
 362 of some function symbol with a logical prefix excluded.
 363
 364 If you subclass `srecode-dictionary-compound-value' then this
 365 method could return nil, but if it does that, it must insert
 366 the value itself using `princ', or by detecting if the current
 367 standard out is a buffer, and using `insert'."
 368   (object-name cp))
 369
 370 (defmethod srecode-dump ((cp srecode-dictionary-compound-value)
 371                          &optional indent)
 372   "Display information about this compound value."
 373   (princ (object-name cp))
 374   )
 375
 376 (defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable)
 377                                       function
 378                                       dictionary)
 379   "Convert the compound dictionary variable value CP into a string.
 380 FUNCTION and DICTIONARY are as for the baseclass."
 381   (require 'srecode/insert)
 382   (srecode-insert-code-stream (oref cp compiled) dictionary))
 383
 384
 385 (defmethod srecode-dump ((cp srecode-dictionary-compound-variable)
 386                          &optional indent)
 387   "Display information about this compound value."
 388   (require 'srecode/compile)
 389   (princ "# Compound Variable #\n")
 390   (let ((indent (+ 4 (or indent 0)))
 391         (cmp (oref cp compiled))
 392         )
 393     (srecode-dump-code-list cmp (make-string indent ? ))
 394     ))
 395
 396 ;;; FIELD EDITING COMPOUND VALUE
 397 ;;
 398 ;; This is an interface to using field-editing objects
 399 ;; instead of asking questions.  This provides the basics
 400 ;; behind this compound value.
 401
 402 (defclass srecode-field-value (srecode-dictionary-compound-value)
 403   ((firstinserter :initarg :firstinserter
 404                   :documentation
 405                   "The inserter object for the first occurrence of this field.")
 406    (defaultvalue :initarg :defaultvalue
 407      :documentation
 408      "The default value for this inserter.")
 409    )
 410   "When inserting values with editable field mode, a dictionary value.
 411 Compound values allow a field to be stored in the dictionary for when
 412 it is referenced a second time.  This compound value can then be
 413 inserted with a new editable field.")
 414
 415 (defmethod srecode-compound-toString((cp srecode-field-value)
 416                                      function
 417                                      dictionary)
 418   "Convert this field into an insertable string."
 419   (require 'srecode/fields)
 420   ;; If we are not in a buffer, then this is not supported.
 421   (when (not (bufferp standard-output))
 422     (error "FIELDS invoked while inserting template to non-buffer"))
 423
 424   (if function
 425       (error "@todo: Cannot mix field insertion with functions")
 426
 427     ;; No function.  Perform a plain field insertion.
 428     ;; We know we are in a buffer, so we can perform the insertion.
 429     (let* ((dv (oref cp defaultvalue))
 430            (sti (oref cp firstinserter))
 431            (start (point))
 432            (name (oref sti :object-name)))
 433
 434       (if (or (not dv) (string= dv ""))
 435           (insert name)
 436         (insert dv))
 437
 438       (srecode-field name :name name
 439                      :start start
 440                      :end (point)
 441                      :prompt (oref sti prompt)
 442                      :read-fcn (oref sti read-fcn)
 443                      )
 444       ))
 445   ;; Returning nil is a signal that we have done the insertion ourselves.
 446   nil)
 447
 448 \f
 449 ;;; Higher level dictionary functions
 450 ;;
 451 (defun srecode-create-section-dictionary (sectiondicts STATE)
 452   "Create a dictionary with section entries for a template.
 453 The format for SECTIONDICTS is what is emitted from the template parsers.
 454 STATE is the current compiler state."
 455   (when sectiondicts
 456     (let ((new (srecode-create-dictionary t)))
 457       ;; Loop over each section.  The section is a macro w/in the
 458       ;; template.
 459       (while sectiondicts
 460         (let* ((sect (car (car sectiondicts)))
 461                (entries (cdr (car sectiondicts)))
 462                (subdict (srecode-dictionary-add-section-dictionary new sect))
 463                )
 464           ;; Loop over each entry.  This is one variable in the
 465           ;; section dictionary.
 466           (while entries
 467             (let ((tname (semantic-tag-name (car entries)))
 468                   (val (semantic-tag-variable-default (car entries))))
 469               (if (eq val t)
 470                   (srecode-dictionary-show-section subdict tname)
 471                 (cond
 472                  ((and (stringp (car val))
 473                        (= (length val) 1))
 474                   (setq val (car val)))
 475                  (t
 476                   (setq val (srecode-dictionary-compound-variable
 477                              tname :value val :state STATE))))
 478                 (srecode-dictionary-set-value
 479                  subdict tname val))
 480               (setq entries (cdr entries))))
 481           )
 482         (setq sectiondicts (cdr sectiondicts)))
 483       new)))
 484
 485 ;;; DUMP DICTIONARY
 486 ;;
 487 ;; Make a dictionary, and dump it's contents.
 488
 489 (defun srecode-adebug-dictionary ()
 490   "Run data-debug on this mode's dictionary."
 491   (interactive)
 492   (require 'eieio-datadebug)
 493   (require 'semantic)
 494   (require 'srecode/find)
 495   (let* ((modesym major-mode)
 496          (start (current-time))
 497          (junk (or (progn (srecode-load-tables-for-mode modesym)
 498                           (srecode-get-mode-table modesym))
 499                    (error "No table found for mode %S" modesym)))
 500          (dict (srecode-create-dictionary (current-buffer)))
 501          (end (current-time))
 502          )
 503     (message "Creating a dictionary took %.2f seconds."
 504              (semantic-elapsed-time start end))
 505     (data-debug-new-buffer "*SRECODE ADEBUG*")
 506     (data-debug-insert-object-slots dict "*")))
 507
 508 (defun srecode-dictionary-dump ()
 509   "Dump a typical fabricated dictionary."
 510   (interactive)
 511   (require 'srecode/find)
 512   (let ((modesym major-mode))
 513     ;; This load allows the dictionary access to inherited
 514     ;; and stacked dictionary entries.
 515     (srecode-load-tables-for-mode modesym)
 516     (let ((tmp (srecode-get-mode-table modesym))
 517           )
 518       (if (not tmp)
 519           (error "No table found for mode %S" modesym))
 520       ;; Now make the dictionary.
 521       (let ((dict (srecode-create-dictionary (current-buffer))))
 522         (with-output-to-temp-buffer "*SRECODE DUMP*"
 523           (princ "DICTIONARY FOR ")
 524           (princ major-mode)
 525           (princ "\n--------------------------------------------\n")
 526           (srecode-dump dict))
 527         ))))
 528
 529 (defmethod srecode-dump ((dict srecode-dictionary) &optional indent)
 530   "Dump a dictionary."
 531   (if (not indent) (setq indent 0))
 532   (maphash (lambda (key entry)
 533              (princ (make-string indent ? ))
 534              (princ " ")
 535              (princ key)
 536              (princ " ")
 537              (cond ((and (listp entry)
 538                          (srecode-dictionary-p (car entry)))
 539                     (let ((newindent (if indent
 540                                          (+ indent 4)
 541                                        4)))
 542                       (while entry
 543                         (princ " --> SUBDICTIONARY ")
 544                         (princ (object-name dict))
 545                         (princ "\n")
 546                         (srecode-dump (car entry) newindent)
 547                         (setq entry (cdr entry))
 548                         ))
 549                     (princ "\n")
 550                     )
 551                    ((srecode-dictionary-compound-value-child-p entry)
 552                     (srecode-dump entry indent)
 553                     (princ "\n")
 554                     )
 555                    (t
 556                     (prin1 entry)
 557                     ;(princ "\n")
 558                     ))
 559              (terpri)
 560              )
 561            (oref dict namehash))
 562   )
 563
 564 (provide 'srecode/dictionary)
 565
 566 ;; arch-tag: c664179c-171c-4709-9b56-d5a2fd30e457
 567 ;;; srecode/dictionary.el ends here