lisp/cedet/srecode/dictionary.el

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